diff options
Diffstat (limited to 'win')
37 files changed, 4149 insertions, 4505 deletions
diff --git a/win/Makefile.in b/win/Makefile.in index 12c04bc..235313f 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -80,12 +80,7 @@ CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@ #CFLAGS = $(CFLAGS_DEBUG) #CFLAGS = $(CFLAGS_OPTIMIZE) #CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE) -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 +CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@ # To enable compilation debugging reverse the comment characters on one of the # following lines. @@ -93,15 +88,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@/.. -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 +GENERIC_DIR = @srcdir@/../generic +TOMMATH_DIR = @srcdir@/../libtommath +WIN_DIR = @srcdir@ +COMPAT_DIR = @srcdir@/../compat # Converts a POSIX path to a Windows native path. CYGPATH = @CYGPATH@ @@ -117,7 +112,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 -P) +LIBRARY_DIR1 = $(shell cd '$(ROOT_DIR_NATIVE)/library' ; pwd) LIBRARY_DIR = $(shell $(CYGPATH) '$(LIBRARY_DIR1)' | sed 's!\\!/!g') DLLSUFFIX = @DLLSUFFIX@ LIBSUFFIX = @LIBSUFFIX@ @@ -134,33 +129,37 @@ 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 = @LIBPREFIX@tcldde$(DDEVER)${LIBSUFFIX} +DDE_LIB_FILE = tcldde$(DDEVER)${LIBSUFFIX} REG_DLL_FILE = tclreg$(REGVER)${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 +REG_LIB_FILE = tclreg$(REGVER)${LIBSUFFIX} +PIPE_DLL_FILE = tclpip$(VER)${DLLSUFFIX} -SHARED_LIBRARIES = $(TCL_DLL_FILE) @ZLIB_DLL_FILE@ -STATIC_LIBRARIES = $(TCL_LIB_FILE) +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 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):$(ZLIB_DIR) +VPATH = $(GENERIC_DIR):$(TOMMATH_DIR):$(WIN_DIR):$(COMPAT_DIR) AR = @AR@ RANLIB = @RANLIB@ @@ -178,10 +177,10 @@ EXEEXT = @EXEEXT@ OBJEXT = @OBJEXT@ STLIB_LD = @STLIB_LD@ SHLIB_LD = @SHLIB_LD@ -SHLIB_LD_LIBS = @SHLIB_LD_LIBS@ +SHLIB_LD_LIBS = @SHLIB_LD_LIBS@ $(LIBS) SHLIB_CFLAGS = @SHLIB_CFLAGS@ SHLIB_SUFFIX = @SHLIB_SUFFIX@ -LIBS = @LIBS@ @ZLIB_LIBS@ +LIBS = @LIBS@ RMDIR = rm -rf MKDIR = mkdir -p @@ -189,7 +188,7 @@ SHELL = @SHELL@ RM = rm -f COPY = cp -CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${TCL_SHLIB_CFLAGS} -I"${ZLIB_DIR}" \ +CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${TCL_SHLIB_CFLAGS} \ -I"${GENERIC_DIR_NATIVE}" -DTCL_TOMMATH -DMP_PREC=4 -I"${TOMMATH_DIR_NATIVE}" \ -I"${WIN_DIR_NATIVE}" ${AC_FLAGS} \ ${COMPILE_DEBUG_FLAGS} ${NO_DEPRECATED_FLAGS} @@ -207,7 +206,8 @@ TCLTEST_OBJS = \ tclTestObj.$(OBJEXT) \ tclTestProcBodyObj.$(OBJEXT) \ tclThreadTest.$(OBJEXT) \ - tclWinTest.$(OBJEXT) + tclWinTest.$(OBJEXT) \ + testMain.$(OBJEXT) GENERIC_OBJS = \ regcomp.$(OBJEXT) \ @@ -215,7 +215,6 @@ GENERIC_OBJS = \ regfree.$(OBJEXT) \ regerror.$(OBJEXT) \ tclAlloc.$(OBJEXT) \ - tclAssembly.$(OBJEXT) \ tclAsync.$(OBJEXT) \ tclBasic.$(OBJEXT) \ tclBinary.$(OBJEXT) \ @@ -225,14 +224,12 @@ GENERIC_OBJS = \ tclCmdIL.$(OBJEXT) \ tclCmdMZ.$(OBJEXT) \ tclCompCmds.$(OBJEXT) \ - tclCompCmdsSZ.$(OBJEXT) \ tclCompExpr.$(OBJEXT) \ tclCompile.$(OBJEXT) \ tclConfig.$(OBJEXT) \ tclDate.$(OBJEXT) \ tclDictObj.$(OBJEXT) \ tclEncoding.$(OBJEXT) \ - tclEnsemble.$(OBJEXT) \ tclEnv.$(OBJEXT) \ tclEvent.$(OBJEXT) \ tclExecute.$(OBJEXT) \ @@ -247,7 +244,6 @@ GENERIC_OBJS = \ tclIOCmd.$(OBJEXT) \ tclIOGT.$(OBJEXT) \ tclIORChan.$(OBJEXT) \ - tclIORTrans.$(OBJEXT) \ tclIOSock.$(OBJEXT) \ tclIOUtil.$(OBJEXT) \ tclLink.$(OBJEXT) \ @@ -255,16 +251,8 @@ 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) \ tclPanic.$(OBJEXT) \ tclParse.$(OBJEXT) \ @@ -282,6 +270,7 @@ GENERIC_OBJS = \ tclStringObj.$(OBJEXT) \ tclStrToD.$(OBJEXT) \ tclStubInit.$(OBJEXT) \ + tclStubLib.$(OBJEXT) \ tclThread.$(OBJEXT) \ tclThreadAlloc.$(OBJEXT) \ tclThreadJoin.$(OBJEXT) \ @@ -291,8 +280,7 @@ GENERIC_OBJS = \ tclTrace.$(OBJEXT) \ tclUtf.$(OBJEXT) \ tclUtil.$(OBJEXT) \ - tclVar.$(OBJEXT) \ - tclZlib.$(OBJEXT) + tclVar.$(OBJEXT) TOMMATH_OBJS = \ bncore.${OBJEXT} \ @@ -377,46 +365,45 @@ WIN_OBJS = \ tclWinThrd.$(OBJEXT) \ tclWinTime.$(OBJEXT) +PIPE_OBJS = stub16.$(OBJEXT) + DDE_OBJS = tclWinDde.$(OBJEXT) REG_OBJS = tclWinReg.$(OBJEXT) -STUB_OBJS = \ - tclStubLib.$(OBJEXT) \ - tclTomMathStubLib.$(OBJEXT) \ - tclOOStubLib.$(OBJEXT) +STUB_OBJS = tclStubLib.$(OBJEXT) TCLSH_OBJS = tclAppInit.$(OBJEXT) -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_OBJS = ${GENERIC_OBJS} $(TOMMATH_OBJS) ${WIN_OBJS} TCL_DOCS = "$(ROOT_DIR_NATIVE)"/doc/*.[13n] -all: binaries libraries doc packages +all: binaries libraries doc -tcltest: $(TCLSH) $(TEST_DLL_FILE) +tcltest: $(TCLTEST) -binaries: $(TCL_STUB_LIB_FILE) @LIBRARIES@ $(DDE_DLL_FILE) $(REG_DLL_FILE) $(TCLSH) +binaries: @LIBRARIES@ $(TCLSH) libraries: doc: -$(TCLSH): $(TCLSH_OBJS) @LIBRARIES@ $(TCL_STUB_LIB_FILE) tclsh.$(RES) - $(CC) $(CFLAGS) $(TCLSH_OBJS) $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \ +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.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE) @VC_MANIFEST_EMBED_EXE@ @@ -434,33 +421,37 @@ ${TCL_STUB_LIB_FILE}: ${STUB_OBJS} @MAKE_LIB@ ${STUB_OBJS} @POST_MAKE_LIB@ -${TCL_DLL_FILE}: ${TCL_OBJS} tcl.$(RES) @ZLIB_DLL_FILE@ - @$(RM) ${TCL_DLL_FILE} $(TCL_LIB_FILE) +${TCL_DLL_FILE}: ${TCL_OBJS} tcl.$(RES) + @$(RM) ${TCL_DLL_FILE} @MAKE_DLL@ ${TCL_OBJS} tcl.$(RES) $(SHLIB_LD_LIBS) @VC_MANIFEST_EMBED_DLL@ -${TCL_LIB_FILE}: ${TCL_OBJS} ${DDE_OBJS} ${REG_OBJS} +${TCL_LIB_FILE}: ${TCL_OBJS} @$(RM) ${TCL_LIB_FILE} - @MAKE_LIB@ ${TCL_OBJS} ${DDE_OBJS} ${REG_OBJS} + @MAKE_LIB@ ${TCL_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) -${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) +${REG_LIB_FILE}: ${REG_OBJS} ${TCL_LIB_FILE} + @$(RM) ${REG_LIB_FILE} + @MAKE_LIB@ ${REG_OBJS} ${TCL_LIB_FILE} -# use pre-built zlib1.dll -${ZLIB_DLL_FILE}: ${TCL_STUB_LIB_FILE} - @if test "@ZLIB_LIBS@set" == "${ZLIB_DIR}/win64/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; +# 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) # Add the object extension to the implicit rules. By default .obj is not # automatically added. @@ -475,13 +466,31 @@ tclWinInit.${OBJEXT}: tclWinInit.c $(CC) -c $(CC_SWITCHES) -DBUILD_tcl $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME) tclWinPipe.${OBJEXT}: tclWinPipe.c - $(CC) -c $(CC_SWITCHES) -DBUILD_tcl $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME) + $(CC) -c $(CC_SWITCHES) -DBUILD_tcl -DTCL_PIPE_DLL=\"$(PIPE_DLL_FILE)\" \ + $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME) testMain.${OBJEXT}: tclAppInit.c $(CC) -c $(CC_SWITCHES) -DTCL_TEST @DEPARG@ $(CC_OBJNAME) -tclMain2.${OBJEXT}: tclMain.c - $(CC) -c $(CC_SWITCHES) -DBUILD_tcl -DTCL_ASCII_MAIN @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) # TIP #59, embedding of configuration information into the binary library. # @@ -513,11 +522,6 @@ 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 @@ -543,11 +547,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-packages +install: all install-binaries install-libraries install-doc install-binaries: binaries @for i in "$(LIB_INSTALL_DIR)" "$(BIN_INSTALL_DIR)" ; \ @@ -559,7 +563,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"; \ @@ -567,14 +571,14 @@ install-binaries: binaries else true; \ fi; \ done; - @for i in $(TCL_DLL_FILE) $(ZLIB_DLL_FILE) $(TCLSH); \ + @for i in $(TCL_DLL_FILE) $(TCLSH) $(PIPE_DLL_FILE); \ do \ if [ -f $$i ]; then \ echo "Installing $$i to $(BIN_INSTALL_DIR)/"; \ $(COPY) $$i "$(BIN_INSTALL_DIR)"; \ fi; \ done - @for i in tclConfig.sh tclooConfig.sh $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE); \ + @for i in tclConfig.sh $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE); \ do \ if [ -f $$i ]; then \ echo "Installing $$i to $(LIB_INSTALL_DIR)/"; \ @@ -583,23 +587,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 @@ -612,7 +616,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 ../tcl8/8.6; \ + @for i in http1.0 opt0.4 encoding ../tcl8 ../tcl8/8.4 ../tcl8/8.4/platform ../tcl8/8.5; \ do \ if [ ! -d $(SCRIPT_INSTALL_DIR)/$$i ] ; then \ echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ @@ -622,7 +626,6 @@ 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"; \ @@ -639,8 +642,8 @@ install-libraries: libraries install-tzdata install-msgs do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \ done; - @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 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 library opt0.4 directory"; @for j in $(ROOT_DIR)/library/opt/*.tcl; \ do \ @@ -650,8 +653,8 @@ install-libraries: libraries install-tzdata install-msgs @$(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 platform 1.0.11 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.11.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"; @$(COPY) $(ROOT_DIR)/library/platform/shell.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform/shell-1.1.4.tm; @echo "Installing encodings"; @@ -661,12 +664,14 @@ install-libraries: libraries install-tzdata install-msgs install-tzdata: @echo "Installing time zone data" - @$(TCL_EXE) "$(ROOT_DIR)/tools/installData.tcl" \ + @TCL_LIBRARY="${LIBRARY_DIR}"; export TCL_LIBRARY; \ + ./$(TCLSH) "$(ROOT_DIR)/tools/installData.tcl" \ "$(ROOT_DIR)/library/tzdata" "$(SCRIPT_INSTALL_DIR)/tzdata" install-msgs: @echo "Installing message catalogs" - @$(TCL_EXE) "$(ROOT_DIR)/tools/installData.tcl" \ + @TCL_LIBRARY="${LIBRARY_DIR}"; export TCL_LIBRARY; \ + ./$(TCLSH) "$(ROOT_DIR)/tools/installData.tcl" \ "$(ROOT_DIR)/library/msgs" "$(SCRIPT_INSTALL_DIR)/msgs" install-doc: doc @@ -684,7 +689,6 @@ 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)"; \ @@ -694,21 +698,17 @@ install-private-headers: libraries # tcltest, i.e.: # % make test TESTFLAGS="-verbose bps -file fileName.test" -test: test-tcl test-packages - -test-tcl: binaries $(TCLSH) $(CAT32) $(TEST_DLL_FILE) +test: binaries $(TCLTEST) TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ - ./$(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) + ./$(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) -# Useful target to launch a built tclsh with the proper path,... -runtest: binaries $(TCLSH) $(TEST_DLL_FILE) +# Useful target to launch a built tcltest with the proper path,... +runtest: binaries $(TCLTEST) @TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ - ./$(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) + ./$(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) # This target can be used to run tclsh from the build directory via # `make shell SCRIPT=foo.tcl` @@ -730,94 +730,16 @@ Makefile: $(SRC_DIR)/Makefile.in cleanhelp: $(RM) *.hlp *.cnt *.GID *.rtf man2tcl.exe -clean: cleanhelp clean-packages +clean: cleanhelp $(RM) *.lib *.a *.exp *.dll *.$(RES) *.${OBJEXT} *~ \#* TAGS a.out - $(RM) $(TCLSH) $(CAT32) + $(RM) $(TCLSH) $(TCLTEST) $(CAT32) $(RM) *.pch *.ilk *.pdb -distclean: distclean-packages clean +distclean: 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. # @@ -831,27 +753,8 @@ 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.6 for Windows +Tcl 8.5 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.6 Source Distribution (plus any patches) + Tcl 8.5 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 -tclsh86.exe. +tclsh85.exe. Note: Tcl no longer provides support for Win32s. diff --git a/win/buildall.vc.bat b/win/buildall.vc.bat index e4f0a30..0c9b3ac 100755..100644 --- a/win/buildall.vc.bat +++ b/win/buildall.vc.bat @@ -59,15 +59,15 @@ if "%INSTALLDIR%" == "" set INSTALLDIR=C:\Program Files\Tcl :: Build the normal stuff along with the help file. :: -set OPTS=none -if not %SYMBOLS%.==. set OPTS=symbols -nmake -nologo -f makefile.vc release htmlhelp OPTS=%OPTS% %1 +set OPTS=threads +if not %SYMBOLS%.==. set OPTS=symbols,threads +nmake -nologo -f makefile.vc release winhelp OPTS=%OPTS% %1 if errorlevel 1 goto error :: Build the static core and shell. :: -set OPTS=static,msvcrt -if not %SYMBOLS%.==. set OPTS=symbols,static,msvcrt +set OPTS=static,msvcrt,threads +if not %SYMBOLS%.==. set OPTS=symbols,static,msvcrt,threads nmake -nologo -f makefile.vc shell OPTS=%OPTS% %1 if errorlevel 1 goto error @@ -9,19 +9,12 @@ * 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 -_tmain(void) +main(void) { char buf[1024]; int n; diff --git a/win/configure b/win/configure index 0b07e9f..a1c0f6d 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 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_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_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: on) + --enable-threads build with threads (default: off) --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,29 +1308,22 @@ 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.6 +TCL_VERSION=8.5 TCL_MAJOR_VERSION=8 -TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".0" +TCL_MINOR_VERSION=5 +TCL_PATCH_LEVEL=".14" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION -TCL_DDE_VERSION=1.4 +TCL_DDE_VERSION=1.3 TCL_DDE_MAJOR_VERSION=1 -TCL_DDE_MINOR_VERSION=4 +TCL_DDE_MINOR_VERSION=3 DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION -TCL_REG_VERSION=1.3 +TCL_REG_VERSION=1.2 TCL_REG_MAJOR_VERSION=1 -TCL_REG_MINOR_VERSION=3 +TCL_REG_MINOR_VERSION=2 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 #------------------------------------------------------------------------ @@ -3064,12 +3057,12 @@ if test "${enable_threads+set}" = set; then enableval="$enable_threads" tcl_ok=$enableval else - tcl_ok=yes + tcl_ok=no fi; if test "$tcl_ok" = "yes"; then - echo "$as_me:$LINENO: result: yes (default)" >&5 -echo "${ECHO_T}yes (default)" >&6 + echo "$as_me:$LINENO: result: yes" >&5 +echo "${ECHO_T}yes" >&6 TCL_THREADS=1 cat >>confdefs.h <<\_ACEOF #define TCL_THREADS 1 @@ -3083,8 +3076,8 @@ _ACEOF else TCL_THREADS=0 - echo "$as_me:$LINENO: result: no" >&5 -echo "${ECHO_T}no" >&6 + echo "$as_me:$LINENO: result: no (default)" >&5 +echo "${ECHO_T}no (default)" >&6 fi @@ -3278,11 +3271,6 @@ 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 @@ -3512,80 +3500,14 @@ 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}' - LIBS="-lnetapi32 -lkernel32 -luser32 -ladvapi32 -lws2_32" + SHLIB_LD_LIBS="" + LIBS="-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' @@ -3599,14 +3521,17 @@ echo $ECHO_N "checking compiler flags... $ECHO_C" >&6 MAKE_EXE="\${CC} -o \$@" LIBPREFIX="lib" - extra_cflags="$extra_cflags -pipe" - extra_ldflags="$extra_ldflags -pipe" + extra_cflags="-pipe" + 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 @@ -3624,30 +3549,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 -Wdeclaration-after-statement" + CFLAGS_WARNING="-Wall" LDFLAGS_DEBUG= LDFLAGS_OPTIMIZE= @@ -3748,23 +3673,28 @@ 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. - LIBRARIES="\${SHARED_LIBRARIES}" + MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -out:\$@" + LIBSUFFIX="\${DBGX}.lib" + LIBFLAGSUFFIX="\${DBGX}" EXESUFFIX="\${DBGX}.exe" + LIBRARIES="\${SHARED_LIBRARIES}" + SHLIB_LD_LIBS='${LIBS}' 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. @@ -3797,7 +3727,7 @@ echo "${ECHO_T} Using 64-bit $MACHINE mode" >&6 fi fi - LIBS="netapi32.lib kernel32.lib user32.lib advapi32.lib ws2_32.lib" + LIBS="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 @@ -3995,7 +3925,6 @@ _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 @@ -4330,66 +4259,6 @@ _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 - - ZLIB_LIBS=\${ZLIB_DIR}/win64/zdll.lib - - -else - - ZLIB_LIBS=\${ZLIB_DIR}/win32/zdll.lib - - -fi - - -else - - ZLIB_OBJS=\${ZLIB_OBJS} - - cat >>confdefs.h <<_ACEOF -#define NO_VIZ 1 -_ACEOF - - -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 @@ -4661,7 +4530,6 @@ _ACEOF fi - #-------------------------------------------------------------------- # Perform additinal compiler tests. #-------------------------------------------------------------------- @@ -4739,217 +4607,6 @@ _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 @@ -5106,6 +4763,12 @@ 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}\"" @@ -5113,10 +4776,6 @@ 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}\"" @@ -5169,12 +4828,6 @@ fi - - - - - - # empty on win @@ -5915,9 +5568,6 @@ 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 @@ -5926,14 +5576,8 @@ 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 b0c007a..33bf784 100644 --- a/win/configure.in +++ b/win/configure.in @@ -11,29 +11,22 @@ AC_PREREQ(2.59) # /bin/sh. The bash shell seems to suffer from some strange failures. SHELL=/bin/sh -TCL_VERSION=8.6 +TCL_VERSION=8.5 TCL_MAJOR_VERSION=8 -TCL_MINOR_VERSION=6 -TCL_PATCH_LEVEL=".0" +TCL_MINOR_VERSION=5 +TCL_PATCH_LEVEL=".14" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION -TCL_DDE_VERSION=1.4 +TCL_DDE_VERSION=1.3 TCL_DDE_MAJOR_VERSION=1 -TCL_DDE_MINOR_VERSION=4 +TCL_DDE_MINOR_VERSION=3 DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION -TCL_REG_VERSION=1.3 +TCL_REG_VERSION=1.2 TCL_REG_MAJOR_VERSION=1 -TCL_REG_MINOR_VERSION=3 +TCL_REG_MINOR_VERSION=2 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 #------------------------------------------------------------------------ @@ -105,40 +98,6 @@ 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"], [ - 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_UNQUOTED(NO_VIZ, 1) -]) -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, [ @@ -170,7 +129,6 @@ AC_CHECK_TYPE([uintptr_t], [ type wide enough to hold a pointer.]) fi ]) - #-------------------------------------------------------------------- # Perform additinal compiler tests. #-------------------------------------------------------------------- @@ -198,65 +156,6 @@ 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 @@ -291,6 +190,12 @@ 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}\"" @@ -298,10 +203,6 @@ 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}\"" @@ -351,15 +252,9 @@ 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 18bfa28..07b2333 100644 --- a/win/makefile.bc +++ b/win/makefile.bc @@ -50,6 +50,7 @@ # # 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. # @@ -123,14 +124,14 @@ CFG_ENCODING = \"cp1252\" NAMEPREFIX = tcl STUBPREFIX = $(NAMEPREFIX)stub -DOTVERSION = 8.6 -VERSION = 86 +DOTVERSION = 8.5 +VERSION = 85 -DDEVERSION = 14 -DDEDOTVERSION = 1.4 +DDEVERSION = 13 +DDEDOTVERSION = 1.3 -REGVERSION = 13 -REGDOTVERSION = 1.3 +REGVERSION = 12 +REGDOTVERSION = 1.2 BINROOT = .. !IF "$(NODEBUG)" == "1" @@ -159,6 +160,8 @@ 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 @@ -200,14 +203,12 @@ TCLOBJS = \ $(TMPDIR)\tclCmdIL.obj \ $(TMPDIR)\tclCmdMZ.obj \ $(TMPDIR)\tclCompCmds.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 \ @@ -230,13 +231,6 @@ 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)\tclPanic.obj \ $(TMPDIR)\tclParse.obj \ @@ -252,6 +246,7 @@ TCLOBJS = \ $(TMPDIR)\tclScan.obj \ $(TMPDIR)\tclStringObj.obj \ $(TMPDIR)\tclStubInit.obj \ + $(TMPDIR)\tclStubLib.obj \ $(TMPDIR)\tclThread.obj \ $(TMPDIR)\tclThreadJoin.obj \ $(TMPDIR)\tclTimer.obj \ @@ -272,13 +267,9 @@ TCLOBJS = \ $(TMPDIR)\tclWinPipe.obj \ $(TMPDIR)\tclWinSock.obj \ $(TMPDIR)\tclWinThrd.obj \ - $(TMPDIR)\tclWinTime.obj \ - $(TMPDIR)\tclZlib.obj + $(TMPDIR)\tclWinTime.obj -TCLSTUBOBJS = \ - $(TMPDIR)\tclStubLib.obj \ - $(TMPDIR)\tclTomMathStubLib.obj \ - $(TMPDIR)\tclOOStubLib.obj +TCLSTUBOBJS = $(TMPDIR)\tclStubLib.obj WINDIR = $(ROOT)\win GENERICDIR = $(ROOT)\generic @@ -287,7 +278,6 @@ 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 @@ -340,7 +330,7 @@ LNLIBS = import32 cw32mt ###################################################################### release: setup $(TCLSH) dlls -dlls: setup $(TCLREGDLL) $(TCLDDEDLL) +dlls: setup $(TCLPIPEDLL) $(TCLREGDLL) $(TCLDDEDLL) all: setup $(TCLSH) dlls $(CAT32) tcltest: setup $(TCLTEST) dlls $(CAT32) plugin: setup $(TCLPLUGINDLL) $(TCLSHP) @@ -389,6 +379,11 @@ $(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),, \ @@ -412,10 +407,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)" @@ -425,10 +420,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.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 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 opt0.4 -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\opt0.4" -@copy "$(ROOT)\library\opt\optparse.tcl" "$(SCRIPT_INSTALL_DIR)\opt0.4" @@ -452,7 +447,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.3" + -@copy "$(TCLREGDLL)" "$(SCRIPT_INSTALL_DIR)\reg1.2" -@copy "$(ROOT)\library\reg\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\reg1.2" @echo installing encoding files -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\encoding" @@ -460,8 +455,6 @@ 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)" @@ -481,6 +474,29 @@ 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 @@ -526,12 +542,6 @@ $(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 2784140..3d17331 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -43,7 +43,8 @@ the build instructions. # # 3) Targets are: # release -- Builds the core, the shell and the dlls. (default) -# dlls -- Just builds the windows extensions +# dlls -- Just builds the windows extensions and the 16-bit DOS +# pipe/thunk helper app. # shell -- Just builds the shell and the core. # core -- Only builds the core [tclXX.(dll|lib)]. # all -- Builds everything. @@ -61,17 +62,15 @@ 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 -- (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) +# winhelp -- Builds the windows .hlp file for Tcl from the troff man +# files found in $(ROOT)\doc. # # 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,nothreads,pdbs,profile,static,staticpkg,symbols,thrdalloc,tclalloc,unchecked,none +# OPTS=loimpact,msvcrt,static,staticpkg,symbols,threads,profile,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. @@ -82,24 +81,17 @@ 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 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 +# dll. The shell will be static (and large), as well. +# staticpkg= Affects the static option only to switch # tclshXX.exe to have the dde and reg extension linked # inside it. -# 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 +# 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 # enabled runtime (msvcrt.dll not msvcrtd.dll # or libcmt.lib not libcmtd.lib). # @@ -190,14 +182,14 @@ STUBPREFIX = $(PROJECT)stub DOTVERSION = $(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION) VERSION = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION) -DDEDOTVERSION = 1.4 +DDEDOTVERSION = 1.3 DDEVERSION = $(DDEDOTVERSION:.=) -REGDOTVERSION = 1.3 +REGDOTVERSION = 1.2 REGVERSION = $(REGDOTVERSION:.=) -BINROOT = $(MAKEDIR) # originally . -ROOT = $(MAKEDIR)\.. # originally .. +BINROOT = . +ROOT = .. TCLIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib TCLLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT) @@ -208,6 +200,8 @@ 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) @@ -236,12 +230,10 @@ 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 = \ @@ -250,21 +242,18 @@ 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 -COREOBJS = \ +TCLOBJS = \ $(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 \ @@ -274,14 +263,12 @@ COREOBJS = \ $(TMP_DIR)\tclCmdIL.obj \ $(TMP_DIR)\tclCmdMZ.obj \ $(TMP_DIR)\tclCompCmds.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 \ @@ -298,22 +285,13 @@ COREOBJS = \ $(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)\tclPanic.obj \ $(TMP_DIR)\tclParse.obj \ @@ -331,6 +309,7 @@ COREOBJS = \ $(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 \ @@ -341,22 +320,20 @@ COREOBJS = \ $(TMP_DIR)\tclUtf.obj \ $(TMP_DIR)\tclUtil.obj \ $(TMP_DIR)\tclVar.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)\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)\bncore.obj \ $(TMP_DIR)\bn_reverse.obj \ $(TMP_DIR)\bn_fast_s_mp_mul_digs.obj \ @@ -420,36 +397,13 @@ TOMMATHOBJS = \ $(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 - -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)\bn_s_mp_sub.obj \ +!if !$(STATIC_BUILD) $(TMP_DIR)\tcl.res !endif -TCLOBJS = $(COREOBJS) $(ZLIBOBJS) $(TOMMATHOBJS) $(PLATFORMOBJS) - TCLSTUBOBJS = \ - $(TMP_DIR)\tclStubLib.obj \ - $(TMP_DIR)\tclTomMathStubLib.obj \ - $(TMP_DIR)\tclOOStubLib.obj + $(TMP_DIR)\tclStubLib.obj ### The following paths CANNOT have spaces in them. COMPATDIR = $(ROOT)\compat @@ -458,7 +412,6 @@ GENERICDIR = $(ROOT)\generic TOMMATHDIR = $(ROOT)\libtommath TOOLSDIR = $(ROOT)\tools WINDIR = $(ROOT)\win -PKGSDIR = $(ROOT)\pkgs #--------------------------------------------------------------------- # Compile flags @@ -500,7 +453,7 @@ crt = -MT !endif TCL_INCLUDES = -I"$(WINDIR)" -I"$(GENERICDIR)" -I"$(TOMMATHDIR)" -TCL_DEFINES = -DTCL_TOMMATH -DMP_PREC=4 -Dinline=__inline -DHAVE_ZLIB=1 +TCL_DEFINES = -DTCL_PIPE_DLL=\"$(TCLPIPEDLLNAME)\" -DTCL_TOMMATH -DMP_PREC=4 -Dinline=__inline BASE_CFLAGS = $(cflags) $(cdebug) $(crt) $(TCL_INCLUDES) $(TCL_DEFINES) CON_CFLAGS = $(cflags) $(cdebug) $(crt) -DCONSOLE TCL_CFLAGS = $(BASE_CFLAGS) $(OPTDEFINES) @@ -543,7 +496,7 @@ dlllflags = $(lflags) -dll conlflags = $(lflags) -subsystem:console guilflags = $(lflags) -subsystem:windows -baselibs = netapi32.lib kernel32.lib user32.lib advapi32.lib ws2_32.lib +baselibs = kernel32.lib user32.lib ws2_32.lib # Avoid 'unresolved external symbol __security_cookie' errors. # c.f. http://support.microsoft.com/?id=894573 !if "$(MACHINE)" == "IA64" || "$(MACHINE)" == "AMD64" @@ -565,27 +518,27 @@ TESTFLAGS = $(TESTFLAGS) -file $(TESTPAT) # Project specific targets #--------------------------------------------------------------------- -release: setup $(TCLSH) $(TCLSTUBLIB) dlls pkgs +release: setup $(TCLSH) $(TCLSTUBLIB) dlls core: setup $(TCLLIB) $(TCLSTUBLIB) shell: setup $(TCLSH) -dlls: setup $(TCLREGLIB) $(TCLDDELIB) -all: setup $(TCLSH) $(TCLSTUBLIB) dlls $(CAT32) pkgs +dlls: setup $(TCLPIPEDLL) $(TCLREGLIB) $(TCLDDELIB) +all: setup $(TCLSH) $(TCLSTUBLIB) dlls $(CAT32) tcltest: setup $(TCLTEST) dlls $(CAT32) -install: install-binaries install-libraries install-docs install-pkgs +install: install-binaries install-libraries install-docs -test: test-core test-pkgs +test: test-core 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.4.0 [list load "$(TCLDDELIB:\=/)" dde] - package ifneeded registry 1.3.0 [list load "$(TCLREGLIB:\=/)" registry] + package ifneeded dde 1.3.3 [list load "$(TCLDDELIB:\=/)" dde] + package ifneeded registry 1.2.2 [list load "$(TCLREGLIB:\=/)" registry] << !else @echo Please wait while the tests are collected... $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << > tests.log - package ifneeded dde 1.4.0 "$(TCLDDELIB:\=/)" dde] - package ifneeded registry 1.3.0 "$(TCLREGLIB:\=/)" registry] + package ifneeded dde 1.3.3 "$(TCLDDELIB:\=/)" dde] + package ifneeded registry 1.2.2 "$(TCLREGLIB:\=/)" registry] << type tests.log | more !endif @@ -617,6 +570,7 @@ $** $** << $(_VC_MANIFEST_EMBED_DLL) + -@del $*.exp !endif $(TCLSTUBLIB): $(TCLSTUBOBJS) @@ -630,6 +584,11 @@ $(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:$@ $** @@ -638,6 +597,8 @@ $(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) @@ -648,40 +609,10 @@ $(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 \ @@ -699,8 +630,6 @@ genstubs: $(TCLSH) $(TOOLSDIR:\=/)/genStubs.tcl $(GENERICDIR:\=/) \ $(GENERICDIR:\=/)/tcl.decls $(GENERICDIR:\=/)/tclInt.decls \ $(GENERICDIR:\=/)/tclTomMath.decls - $(TCLSH) $(TOOLSDIR:\=/)/genStubs.tcl $(GENERICDIR:\=/) \ - $(GENERICDIR:\=/)/tclOO.decls !endif @@ -916,10 +845,6 @@ $(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$@ $? @@ -929,9 +854,6 @@ $(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:\=\\)\"" \ @@ -977,12 +899,6 @@ $(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 @@ -1018,9 +934,7 @@ $(TCLOBJS) #--------------------------------------------------------------------- -# Implicit rules. A limitation exists with nmake that requires that -# source directory can not contain spaces in the path. This an -# absolute. +# Implicit rules #--------------------------------------------------------------------- {$(WINDIR)}.c{$(TMP_DIR)}.obj:: @@ -1043,11 +957,6 @@ $< $< << -{$(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) \ @@ -1074,6 +983,10 @@ 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)\" @@ -1094,13 +1007,9 @@ 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)\" @@ -1118,7 +1027,6 @@ 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\" @@ -1127,7 +1035,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.6\http-$(PKG_HTTP_VER).tm" + "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4\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" @@ -1198,7 +1106,7 @@ tidy: @echo Removing $(TCLREGLIB) ... @if exist $(TCLREGLIB) del $(TCLREGLIB) -clean: clean-pkgs +clean: @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 b1a1517..d0edcf0 100644 --- a/win/nmakehlp.c +++ b/win/nmakehlp.c @@ -498,10 +498,9 @@ GetVersionFromFile( p = strstr(szBuffer, match); if (p != NULL) { /* - * Skip to first digit after the match. + * Skip to first digit. */ - p += strlen(match); while (*p && !isdigit(*p)) { ++p; } @@ -631,11 +630,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) { @@ -655,7 +654,7 @@ SubstituteFile( } printf(szBuffer); } - + list_free(&substPtr); } fclose(fp); diff --git a/win/rules.vc b/win/rules.vc index 1513198..bbf7485 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -159,7 +159,7 @@ DEBUGFLAGS = $(DEBUGFLAGS) -RTC1 DEBUGFLAGS = $(DEBUGFLAGS) -GZ !endif -COMPILERFLAGS =-W3 -DUNICODE -D_UNICODE +COMPILERFLAGS =-W3 # 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 = 1 +TCL_THREADS = 0 DEBUG = 0 SYMBOLS = 0 PROFILE = 0 @@ -221,7 +221,7 @@ PGO = 0 MSVCRT = 1 LOIMPACT = 0 TCL_USE_STATIC_PACKAGES = 0 -USE_THREAD_ALLOC = 1 +USE_THREAD_ALLOC = 0 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) "nothreads"] -!message *** Compile explicitly for non-threaded tcl -TCL_THREADS = 0 -USE_THREAD_ALLOC= 0 -!else +!if [nmakehlp -f $(OPTS) "threads"] +!message *** Doing threads TCL_THREADS = 1 -USE_THREAD_ALLOC= 1 +USE_THREAD_ALLOC = 1 +!else +TCL_THREADS = 0 +USE_THREAD_ALLOC = 0 !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\tclreg13$(SUFX:t=).lib" -TCLDDELIB = "$(_TCLDIR)\lib\tcldde14$(SUFX:t=).lib" +TCLREGLIB = "$(_TCLDIR)\lib\tclreg12$(SUFX:t=).lib" +TCLDDELIB = "$(_TCLDIR)\lib\tcldde13$(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)\tclreg13$(SUFX:t=).lib" -TCLDDELIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcldde14$(SUFX:t=).lib" +TCLREGLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclreg12$(SUFX:t=).lib" +TCLDDELIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcldde13$(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 new file mode 100644 index 0000000..70fc051 --- /dev/null +++ b/win/stub16.c @@ -0,0 +1,195 @@ +/* + * 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 57ec6bf..b3de0ff 100644 --- a/win/tcl.dsp +++ b/win/tcl.dsp @@ -1300,14 +1300,6 @@ 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 @@ -1460,6 +1452,10 @@ 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 @@ -1560,6 +1556,10 @@ 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 3bdccbe..0d01f35 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=tcl86.cnt +CNT=tcl85.cnt COPYRIGHT=Copyright © 2000 Ajuba Solutions -HLP=tcl86.hlp +HLP=tcl85.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: on)], - [tcl_ok=$enableval], [tcl_ok=yes]) + AC_ARG_ENABLE(threads, [ --enable-threads build with threads (default: off)], + [tcl_ok=$enableval], [tcl_ok=no]) if test "$tcl_ok" = "yes"; then - AC_MSG_RESULT([yes (default)]) + AC_MSG_RESULT(yes) 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) + AC_MSG_RESULT([no (default)]) fi AC_SUBST(TCL_THREADS) ]) @@ -556,7 +556,6 @@ 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) @@ -646,31 +645,13 @@ 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}' - LIBS="-lnetapi32 -lkernel32 -luser32 -ladvapi32 -lws2_32" + SHLIB_LD_LIBS="" + LIBS="-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' @@ -684,13 +665,16 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ MAKE_EXE="\${CC} -o \[$]@" LIBPREFIX="lib" - extra_cflags="$extra_cflags -pipe" - extra_ldflags="$extra_ldflags -pipe" + extra_cflags="-pipe" + 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 @@ -704,30 +688,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 -Wdeclaration-after-statement" + CFLAGS_WARNING="-Wall" LDFLAGS_DEBUG= LDFLAGS_OPTIMIZE= @@ -782,22 +766,27 @@ 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. - LIBRARIES="\${SHARED_LIBRARIES}" + MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -out:\[$]@" + LIBSUFFIX="\${DBGX}.lib" + LIBFLAGSUFFIX="\${DBGX}" EXESUFFIX="\${DBGX}.exe" + LIBRARIES="\${SHARED_LIBRARIES}" + SHLIB_LD_LIBS='${LIBS}' 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. @@ -827,7 +816,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ fi fi - LIBS="netapi32.lib kernel32.lib user32.lib advapi32.lib ws2_32.lib" + LIBS="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 @@ -952,7 +941,6 @@ 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 @@ -1112,13 +1100,13 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ #------------------------------------------------------------------------ AC_DEFUN([SC_WITH_TCL], [ - if test -d ../../tcl8.6$1/win; then - TCL_BIN_DEFAULT=../../tcl8.6$1/win + if test -d ../../tcl8.5$1/win; then + TCL_BIN_DEFAULT=../../tcl8.5$1/win else - TCL_BIN_DEFAULT=../../tcl8.6/win + TCL_BIN_DEFAULT=../../tcl8.5/win fi - AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl 8.6 binaries from DIR], + AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl 8.5 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 753eaff..0edd2c3 100644 --- a/win/tclAppInit.c +++ b/win/tclAppInit.c @@ -2,63 +2,30 @@ * tclAppInit.c -- * * Provides a default version of the main program and Tcl_AppInit - * procedure for tclsh and other Tcl-based applications (without Tk). - * Note that this program must be built in Win32 console mode to work properly. + * function for Tcl applications (without Tk). Note that this program + * must be built in Win32 console mode to work properly. * - * Copyright (c) 1993 The Regents of the University of California. - * Copyright (c) 1994-1997 Sun Microsystems, Inc. - * Copyright (c) 1998-1999 Scriptics Corporation. + * Copyright (c) 1996-1997 by Sun Microsystems, Inc. + * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #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 Tcltest_Init; -extern Tcl_PackageInitProc Tcltest_SafeInit; +extern Tcl_PackageInitProc Procbodytest_Init; +extern Tcl_PackageInitProc Procbodytest_SafeInit; +extern Tcl_PackageInitProc Tcltest_Init; +extern Tcl_PackageInitProc TclObjTest_Init; #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; -#endif - -#ifdef TCL_BROKEN_MAINARGS -static void setargv(int *argcPtr, TCHAR ***argvPtr); -#endif - -/* - * 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 -#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 +#if defined(__GNUC__) +static void setargv(int *argcPtr, char ***argvPtr); +#endif /* __GNUC__ */ /* *---------------------------------------------------------------------- @@ -68,45 +35,53 @@ MODULE_SCOPE int TCL_LOCAL_MAIN_HOOK(int *argc, TCHAR ***argv); * This is the main program for the application. * * Results: - * None: Tcl_Main never returns here, so this procedure never returns + * None: Tcl_Main never returns here, so this function never returns * either. * * Side effects: - * Just about anything, since from here we call arbitrary Tcl code. + * Whatever the application does. * *---------------------------------------------------------------------- */ -#ifdef TCL_BROKEN_MAINARGS int main( int argc, - char *dummy[]) -{ - TCHAR **argv; -#else -int -_tmain( - int argc, - TCHAR *argv[]) + char *argv[]) { + /* + * 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 - TCHAR *p; + extern int TCL_LOCAL_APPINIT (Tcl_Interp *interp); /* - * Set up the default locale to be standard "C" locale so parsing is - * performed correctly. + * 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() */ - setlocale(LC_ALL, "C"); +#ifdef TCL_LOCAL_MAIN_HOOK + extern int TCL_LOCAL_MAIN_HOOK (int *argc, char ***argv); +#endif + + char *p; -#ifdef TCL_BROKEN_MAINARGS /* - * Get our args from the c-runtime. Ignore lpszCmdLine. + * Set up the default locale to be standard "C" locale so parsing is + * performed correctly. */ - setargv(&argc, &argv); +#if defined(__GNUC__) + setargv( &argc, &argv ); #endif + setlocale(LC_ALL, "C"); /* * Forward slashes substituted for backslashes. @@ -123,6 +98,7 @@ _tmain( #endif Tcl_Main(argc, argv, TCL_LOCAL_APPINIT); + return 0; /* Needed only to prevent compiler warning. */ } @@ -131,9 +107,9 @@ _tmain( * * Tcl_AppInit -- * - * This procedure performs application-specific initialization. Most + * This function performs application-specific initialization. Most * applications, especially those that incorporate additional packages, - * will have their own version of this procedure. + * will have their own version of this function. * * Results: * Returns a standard Tcl completion code, and leaves an error message in @@ -149,55 +125,67 @@ int Tcl_AppInit( Tcl_Interp *interp) /* Interpreter for application. */ { - if ((Tcl_Init)(interp) == TCL_ERROR) { + if (Tcl_Init(interp) == TCL_ERROR) { return TCL_ERROR; } -#if defined(STATIC_BUILD) && TCL_USE_STATIC_PACKAGES - if (Registry_Init(interp) == TCL_ERROR) { +#ifdef TCL_TEST + if (Tcltest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } - Tcl_StaticPackage(interp, "registry", Registry_Init, NULL); - - if (Dde_Init(interp) == TCL_ERROR) { + Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, NULL); + if (TclObjTest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } - Tcl_StaticPackage(interp, "dde", Dde_Init, Dde_SafeInit); -#endif - -#ifdef TCL_TEST - if (Tcltest_Init(interp) == TCL_ERROR) { + if (Procbodytest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } - Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, Tcltest_SafeInit); + Tcl_StaticPackage(interp, "procbodytest", Procbodytest_Init, + Procbodytest_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 procedures for included packages. Each call should look + * Call the init functions 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. (Dynamically-loadable packages - * should have the same entry-point name.) + * where "Mod" is the name of the module. */ /* * Call Tcl_CreateCommand for application-specific commands, if they - * weren't already created by the init procedures called above. + * weren't already created by the init functions called above. */ /* * Specify a user-specific startup file to invoke if the application is * run interactively. Typically the startup file is "~/.apprc" where "app" - * is the name of the application. If this line is deleted then no user- - * specific startup file will be run under any conditions. + * is the name of the application. If this line is deleted then no + * user-specific startup file will be run under any conditions. */ - (Tcl_ObjSetVar2)(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL, - Tcl_NewStringObj("~/tclshrc.tcl", -1), TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "tcl_rcFileName", "~/tclshrc.tcl", TCL_GLOBAL_ONLY); return TCL_OK; } @@ -228,17 +216,17 @@ Tcl_AppInit( *-------------------------------------------------------------------------- */ -#ifdef TCL_BROKEN_MAINARGS +#if defined(__GNUC__) static void setargv( int *argcPtr, /* Filled with number of argument strings. */ - TCHAR ***argvPtr) /* Filled with argument strings (malloc'd). */ + char ***argvPtr) /* Filled with argument strings (malloc'd). */ { - TCHAR *cmdLine, *p, *arg, *argSpace; - TCHAR **argv; + char *cmdLine, *p, *arg, *argSpace; + char **argv; int argc, size, inquote, copy, slashes; - cmdLine = GetCommandLine(); + cmdLine = GetCommandLine(); /* INTL: BUG */ /* * Precompute an overly pessimistic guess at the number of arguments in @@ -257,15 +245,10 @@ setargv( } } } - - /* 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)); + argSpace = (char *) ckalloc( + (unsigned) (size * sizeof(char *) + strlen(cmdLine) + 1)); + argv = (char **) argSpace; + argSpace += size * sizeof(char *); size--; p = cmdLine; @@ -323,7 +306,7 @@ setargv( *argcPtr = argc; *argvPtr = argv; } -#endif /* TCL_BROKEN_MAINARGS */ +#endif /* __GNUC__ */ /* * Local Variables: diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index 019d76f..6c863b9 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.c @@ -12,9 +12,30 @@ */ #include "tclWinInt.h" -#if defined(HAVE_INTRIN_H) -# include <intrin.h> -#endif + +#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); /* * The following variables keep track of information about this DLL on a @@ -50,14 +71,150 @@ typedef struct EXCEPTION_REGISTRATION { #define cpuid __asm __emit 0fh __asm __emit 0a2h #endif -static Tcl_Encoding winTCharEncoding = NULL; +/* + * 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, + /* + * 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 @@ -66,8 +223,8 @@ BOOL APIENTRY DllMain(HINSTANCE hInst, DWORD reason, */ typedef struct MountPointMap { - const TCHAR *volumeName; /* Native wide string volume name. */ - TCHAR driveLetter; /* Drive letter corresponding to the volume + CONST WCHAR *volumeName; /* Native wide string volume name. */ + char driveLetter; /* Drive letter corresponding to the volume * name. */ struct MountPointMap *nextPtr; /* Pointer to next structure in list, or @@ -86,6 +243,8 @@ TCL_DECLARE_MUTEX(mountPointMap) * We will need this below. */ +extern Tcl_FSDupInternalRepProc TclNativeDupInternalRep; + #ifdef __WIN32__ #ifndef STATIC_BUILD @@ -128,7 +287,10 @@ DllEntryPoint( * TRUE on sucess, FALSE on failure. * * Side effects: - * Initializes most rudimentary Windows bits. + * 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." * *---------------------------------------------------------------------- */ @@ -139,16 +301,105 @@ 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: /* - * DLL_PROCESS_DETACH is unnecessary as the user should call - * Tcl_Finalize explicitly before unloading Tcl. + * 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. */ + +#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; @@ -206,18 +457,15 @@ TclWinInit( platformId = os.dwPlatformId; /* - * We no longer support Win32s or Win9x, so just in case someone manages - * to get a runtime there, make sure they know that. + * We no longer support Win32s, 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"); - } - TclWinResetInterfaces(); + tclWinProcs = &asciiProcs; } /* @@ -230,10 +478,9 @@ 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 (not supported) - * VER_PLATFORM_WIN32_NT Win32 on Windows NT, 2000, XP - * VER_PLATFORM_WIN32_CE Win32 on Windows CE + * 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 * * Side effects: * None. @@ -279,6 +526,83 @@ 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 -- @@ -306,17 +630,107 @@ TclWinSetInterfaces( int wide) /* Non-zero to use wide interfaces, 0 * otherwise. */ { - TclWinResetInterfaces(); + Tcl_FreeEncoding(tclWinTCharEncoding); if (wide) { - winTCharEncoding = Tcl_GetEncoding(NULL, "unicode"); + 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); + } + } } } /* *--------------------------------------------------------------------------- * - * TclWinEncodingsCleanup -- + * TclWinResetInterfaceEncodings -- * * Called during finalization to free up any encodings we use. The * tclWinProcs-> look up table is still ok to use after this call, @@ -336,11 +750,13 @@ TclWinSetInterfaces( */ void -TclWinEncodingsCleanup(void) +TclWinResetInterfaceEncodings(void) { MountPointMap *dlIter, *dlIter2; - - TclWinResetInterfaces(); + if (tclWinTCharEncoding != NULL) { + Tcl_FreeEncoding(tclWinTCharEncoding); + tclWinTCharEncoding = NULL; + } /* * Clean up the mount point map. @@ -350,8 +766,8 @@ TclWinEncodingsCleanup(void) dlIter = driveLetterLookup; while (dlIter != NULL) { dlIter2 = dlIter->nextPtr; - ckfree(dlIter->volumeName); - ckfree(dlIter); + ckfree((char*)dlIter->volumeName); + ckfree((char*)dlIter); dlIter = dlIter2; } Tcl_MutexUnlock(&mountPointMap); @@ -377,10 +793,7 @@ TclWinEncodingsCleanup(void) void TclWinResetInterfaces(void) { - if (winTCharEncoding != NULL) { - Tcl_FreeEncoding(winTCharEncoding); - winTCharEncoding = NULL; - } + tclWinProcs = &asciiProcs; } /* @@ -407,11 +820,11 @@ TclWinResetInterfaces(void) char TclWinDriveLetterForVolMountPoint( - const TCHAR *mountPoint) + CONST WCHAR *mountPoint) { MountPointMap *dlIter, *dlPtr2; - TCHAR Target[55]; /* Target of mount at mount point */ - TCHAR drive[4] = TEXT("A:\\"); + WCHAR Target[55]; /* Target of mount at mount point */ + WCHAR drive[4] = { L'A', L':', L'\\', L'\0' }; /* * Detect the volume mounted there. Unfortunately, there is no simple way @@ -422,28 +835,28 @@ TclWinDriveLetterForVolMountPoint( Tcl_MutexLock(&mountPointMap); dlIter = driveLetterLookup; while (dlIter != NULL) { - if (_tcscmp(dlIter->volumeName, mountPoint) == 0) { + if (wcscmp(dlIter->volumeName, mountPoint) == 0) { /* * We need to check whether this information is still valid, since * either the user or various programs could have adjusted the * mount points on the fly. */ - drive[0] = (TCHAR) dlIter->driveLetter; + drive[0] = L'A' + (dlIter->driveLetter - 'A'); /* * Try to read the volume mount point and see where it points. */ - if (GetVolumeNameForVolumeMountPoint(drive, - Target, 55) != 0) { - if (_tcscmp(dlIter->volumeName, Target) == 0) { + if ((*tclWinProcs->getVolumeNameForVMPProc)((TCHAR*)drive, + (TCHAR*)Target, 55) != 0) { + if (wcscmp((WCHAR*)dlIter->volumeName, Target) == 0) { /* * Nothing has changed. */ Tcl_MutexUnlock(&mountPointMap); - return (char) dlIter->driveLetter; + return dlIter->driveLetter; } } @@ -470,8 +883,8 @@ TclWinDriveLetterForVolMountPoint( * Now dlPtr2 points to the structure to free. */ - ckfree(dlPtr2->volumeName); - ckfree(dlPtr2); + ckfree((char*)dlPtr2->volumeName); + ckfree((char*)dlPtr2); /* * Restart the loop - we could try to be clever and continue half @@ -494,23 +907,23 @@ TclWinDriveLetterForVolMountPoint( * Try to read the volume mount point and see where it points. */ - if (GetVolumeNameForVolumeMountPoint(drive, - Target, 55) != 0) { + if ((*tclWinProcs->getVolumeNameForVMPProc)((TCHAR*)drive, + (TCHAR*)Target, 55) != 0) { int alreadyStored = 0; for (dlIter = driveLetterLookup; dlIter != NULL; dlIter = dlIter->nextPtr) { - if (_tcscmp(dlIter->volumeName, Target) == 0) { + if (wcscmp((WCHAR*)dlIter->volumeName, Target) == 0) { alreadyStored = 1; break; } } if (!alreadyStored) { - dlPtr2 = ckalloc(sizeof(MountPointMap)); + dlPtr2 = (MountPointMap *) ckalloc(sizeof(MountPointMap)); dlPtr2->volumeName = TclNativeDupInternalRep(Target); - dlPtr2->driveLetter = (char) drive[0]; + dlPtr2->driveLetter = 'A' + (drive[0] - L'A'); dlPtr2->nextPtr = driveLetterLookup; - driveLetterLookup = dlPtr2; + driveLetterLookup = dlPtr2; } } } @@ -521,9 +934,9 @@ TclWinDriveLetterForVolMountPoint( for (dlIter = driveLetterLookup; dlIter != NULL; dlIter = dlIter->nextPtr) { - if (_tcscmp(dlIter->volumeName, mountPoint) == 0) { + if (wcscmp(dlIter->volumeName, mountPoint) == 0) { Tcl_MutexUnlock(&mountPointMap); - return (char) dlIter->driveLetter; + return dlIter->driveLetter; } } @@ -532,11 +945,11 @@ TclWinDriveLetterForVolMountPoint( * that fact and store '-1' so we don't have to look it up each time. */ - dlPtr2 = ckalloc(sizeof(MountPointMap)); - dlPtr2->volumeName = TclNativeDupInternalRep((ClientData) mountPoint); + dlPtr2 = (MountPointMap*) ckalloc(sizeof(MountPointMap)); + dlPtr2->volumeName = TclNativeDupInternalRep((ClientData)mountPoint); dlPtr2->driveLetter = -1; dlPtr2->nextPtr = driveLetterLookup; - driveLetterLookup = dlPtr2; + driveLetterLookup = dlPtr2; Tcl_MutexUnlock(&mountPointMap); return -1; } @@ -593,27 +1006,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(winTCharEncoding, + return (TCHAR *) Tcl_UtfToExternalDString(tclWinTCharEncoding, 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(winTCharEncoding, - (const char *) string, len, dsPtr); + return Tcl_ExternalToUtfDString(tclWinTCharEncoding, + (CONST char *) string, len, dsPtr); } /* @@ -641,16 +1054,11 @@ TclWinCPUID( { int status = TCL_ERROR; -#if defined(HAVE_INTRIN_H) && defined(_WIN64) - - __cpuid(regsPtr, index); - status = TCL_OK; - -#elif defined(__GNUC__) +#if defined(__GNUC__) # if defined(_WIN64) /* * Execute the CPUID instruction with the given index, and store results - * off 'regPtr'. + * off 'regsPtr'. */ __asm__ __volatile__( diff --git a/win/tclWinChan.c b/win/tclWinChan.c index 52b9e32..8aa2772 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 const Tcl_ChannelType fileChannelType = { +static Tcl_ChannelType fileChannelType = { "file", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ FileCloseProc, /* Close proc. */ @@ -117,7 +117,7 @@ static const 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 const 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 = ckalloc(sizeof(FileEvent)); + evPtr = (FileEvent *) 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 = instanceData; + FileInfo *infoPtr = (FileInfo *) 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 = instanceData; + FileInfo *fileInfoPtr = (FileInfo *) instanceData; FileInfo *infoPtr; ThreadSpecificData *tsdPtr; int errorCode = 0; @@ -441,7 +441,7 @@ FileCloseProc( break; } } - ckfree(fileInfoPtr); + ckfree((char *)fileInfoPtr); return errorCode; } @@ -470,7 +470,7 @@ FileSeekProc( int mode, /* Relative to where should we seek? */ int *errorCodePtr) /* To store error code. */ { - FileInfo *infoPtr = instanceData; + FileInfo *infoPtr = (FileInfo *) 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 = instanceData; + FileInfo *infoPtr = (FileInfo *) instanceData; DWORD moveMethod; LONG newPos, newPosHigh; @@ -597,7 +597,7 @@ FileTruncateProc( ClientData instanceData, /* File state. */ Tcl_WideInt length) /* Length to truncate at. */ { - FileInfo *infoPtr = instanceData; + FileInfo *infoPtr = (FileInfo *) instanceData; LONG newPos, newPosHigh, oldPos, oldPosHigh; /* @@ -673,10 +673,11 @@ FileInputProc( int bufSize, /* Num bytes available in buffer. */ int *errorCode) /* Where to store error code. */ { - FileInfo *infoPtr = instanceData; + FileInfo *infoPtr; DWORD bytesRead; *errorCode = 0; + infoPtr = (FileInfo *) instanceData; /* * Note that we will block on reads from a console buffer until a full @@ -720,11 +721,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 = instanceData; + FileInfo *infoPtr = (FileInfo *) instanceData; DWORD bytesWritten; *errorCode = 0; @@ -771,7 +772,7 @@ FileWatchProc( * of TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ { - FileInfo *infoPtr = instanceData; + FileInfo *infoPtr = (FileInfo *) instanceData; Tcl_Time blockTime = { 0, 0 }; /* @@ -809,7 +810,7 @@ FileGetHandleProc( int direction, /* TCL_READABLE or TCL_WRITABLE */ ClientData *handlePtr) /* Where to store the handle. */ { - FileInfo *infoPtr = instanceData; + FileInfo *infoPtr = (FileInfo *) instanceData; if (direction & infoPtr->validMask) { *handlePtr = (ClientData) infoPtr->handle; @@ -849,12 +850,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 = Tcl_FSGetNativePath(pathPtr); + nativeName = (TCHAR*) Tcl_FSGetNativePath(pathPtr); if (nativeName == NULL) { return NULL; } @@ -913,7 +914,7 @@ TclpOpenFileChannel( flags = FILE_ATTRIBUTE_READONLY; } } else { - flags = GetFileAttributes(nativeName); + flags = (*tclWinProcs->getFileAttributesProc)(nativeName); if (flags == 0xFFFFFFFF) { flags = 0; } @@ -929,8 +930,8 @@ TclpOpenFileChannel( * Now we get to create the file. */ - handle = CreateFile(nativeName, accessMode, shareMode, - NULL, createMode, flags, (HANDLE) NULL); + handle = (*tclWinProcs->createFileProc)(nativeName, accessMode, + shareMode, NULL, createMode, flags, (HANDLE) NULL); if (handle == INVALID_HANDLE_VALUE) { DWORD err = GetLastError(); @@ -940,9 +941,8 @@ TclpOpenFileChannel( } TclWinConvertError(err); if (interp != (Tcl_Interp *) NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't open \"%s\": %s", - TclGetString(pathPtr), Tcl_PosixError(interp))); + Tcl_AppendResult(interp, "couldn't open \"", TclGetString(pathPtr), + "\": ", Tcl_PosixError(interp), NULL); } return NULL; } @@ -960,9 +960,9 @@ TclpOpenFileChannel( if (handle == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); if (interp != (Tcl_Interp *) NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't reopen serial \"%s\": %s", - TclGetString(pathPtr), Tcl_PosixError(interp))); + Tcl_AppendResult(interp, "couldn't reopen serial \"", + TclGetString(pathPtr), "\": ", + Tcl_PosixError(interp), NULL); } return NULL; } @@ -996,11 +996,8 @@ TclpOpenFileChannel( */ channel = NULL; - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't open \"%s\": bad file type", - TclGetString(pathPtr))); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "BAD_TYPE", - NULL); + Tcl_AppendResult(interp, "couldn't open \"", TclGetString(pathPtr), + "\": bad file type", NULL); break; } @@ -1226,8 +1223,8 @@ TclpGetDefaultStdChannel( Tcl_Channel channel; HANDLE handle; int mode = -1; - const char *bufMode = NULL; - DWORD handleId = (DWORD) -1; + char *bufMode = NULL; + DWORD handleId = (DWORD)-1; /* Standard handle to retrieve. */ switch (type) { @@ -1326,7 +1323,7 @@ TclWinOpenFileChannel( } } - infoPtr = ckalloc(sizeof(FileInfo)); + infoPtr = (FileInfo *) ckalloc((unsigned) sizeof(FileInfo)); /* * TIP #218. Removed the code inserting the new structure into the global @@ -1340,10 +1337,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, - infoPtr, permissions); + (ClientData) infoPtr, permissions); /* * Files have default translation of AUTO and ^Z eof char, which means @@ -1417,7 +1414,7 @@ FileThreadActionProc( int action) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - FileInfo *infoPtr = instanceData; + FileInfo *infoPtr = (FileInfo *) instanceData; if (action == TCL_CHANNEL_THREAD_INSERT) { infoPtr->nextPtr = tsdPtr->firstFilePtr; diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 65e4aed..361fb3d 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -12,6 +12,9 @@ #include "tclWinInt.h" +#include <fcntl.h> +#include <io.h> + /* * The following variable is used to tell whether this module has been * initialized. @@ -45,23 +48,6 @@ 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. */ @@ -80,18 +66,24 @@ typedef struct ConsoleInfo { Tcl_ThreadId threadId; /* Thread to which events should be reported. * This value is used by the reader/writer * threads. */ - 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. */ + 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 */ 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 @@ -106,8 +98,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; @@ -141,8 +133,7 @@ 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); @@ -154,7 +145,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); @@ -163,22 +154,13 @@ 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 const Tcl_ChannelType consoleChannelType = { +static Tcl_ChannelType consoleChannelType = { "console", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ ConsoleCloseProc, /* Close proc. */ @@ -190,27 +172,23 @@ static const 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 proc. */ + ConsoleBlockModeProc, /* Set blocking or non-blocking mode.*/ + NULL, /* flush proc. */ + NULL, /* handler proc. */ + NULL, /* wide seek proc */ + ConsoleThreadActionProc, /* thread action proc */ + NULL, /* truncation */ }; /* *---------------------------------------------------------------------- * - * 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, @@ -218,32 +196,30 @@ ReadConsoleBytes( { DWORD ntchars; BOOL result; - int tcharsize = sizeof(TCHAR); - - result = ReadConsole(hConsole, lpBuffer, nbytes / tcharsize, &ntchars, - NULL); - if (nbytesread != NULL) { - *nbytesread = ntchars * tcharsize; - } + int tcharsize; + tcharsize = tclWinProcs->useWide? 2 : 1; + result = tclWinProcs->readConsoleProc( + hConsole, lpBuffer, nbytes / tcharsize, &ntchars, NULL); + if (nbytesread) + *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 = sizeof(TCHAR); - - result = WriteConsole(hConsole, lpBuffer, nbytes / tcharsize, &ntchars, - NULL); - if (nbyteswritten != NULL) { - *nbyteswritten = ntchars * tcharsize; - } + int tcharsize; + tcharsize = tclWinProcs->useWide? 2 : 1; + result = tclWinProcs->writeConsoleProc( + hConsole, lpBuffer, nbytes / tcharsize, &ntchars, NULL); + if (nbyteswritten) + *nbyteswritten = (ntchars*tcharsize); return result; } @@ -266,6 +242,8 @@ WriteConsoleBytes( static void ConsoleInit(void) { + ThreadSpecificData *tsdPtr; + /* * Check the initialized flag first, then check again in the mutex. This * is a speed enhancement. @@ -280,9 +258,9 @@ ConsoleInit(void) Tcl_MutexUnlock(&consoleMutex); } - if (TclThreadDataKeyGet(&dataKey) == NULL) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - + tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); + if (tsdPtr == NULL) { + tsdPtr = TCL_TSD_INIT(&dataKey); tsdPtr->firstConsolePtr = NULL; Tcl_CreateEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL); Tcl_CreateThreadExitHandler(ConsoleExitHandler, NULL); @@ -308,7 +286,7 @@ ConsoleInit(void) static void ConsoleExitHandler( - ClientData clientData) /* Old window proc. */ + ClientData clientData) /* Old window proc */ { Tcl_DeleteEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL); } @@ -332,7 +310,7 @@ ConsoleExitHandler( static void ProcExitHandler( - ClientData clientData) /* Old window proc. */ + ClientData clientData) /* Old window proc */ { Tcl_MutexLock(&consoleMutex); initialized = 0; @@ -377,8 +355,7 @@ ConsoleSetupProc( for (infoPtr = tsdPtr->firstConsolePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (infoPtr->watchMask & TCL_WRITABLE) { - if (WaitForSingleObject(infoPtr->writer.readyEvent, - 0) != WAIT_TIMEOUT) { + if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) { block = 0; } } @@ -416,6 +393,7 @@ ConsoleCheckProc( int flags) /* Event flags as passed to Tcl_DoOneEvent. */ { ConsoleInfo *infoPtr; + ConsoleEvent *evPtr; int needEvent; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -440,8 +418,7 @@ ConsoleCheckProc( needEvent = 0; if (infoPtr->watchMask & TCL_WRITABLE) { - if (WaitForSingleObject(infoPtr->writer.readyEvent, - 0) != WAIT_TIMEOUT) { + if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) { needEvent = 1; } } @@ -453,9 +430,8 @@ 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); @@ -463,6 +439,7 @@ ConsoleCheckProc( } } + /* *---------------------------------------------------------------------- * @@ -485,7 +462,7 @@ ConsoleBlockModeProc( int mode) /* TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ { - ConsoleInfo *infoPtr = instanceData; + ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData; /* * Consoles on Windows can not be switched between blocking and @@ -498,7 +475,7 @@ ConsoleBlockModeProc( if (mode == TCL_MODE_NONBLOCKING) { infoPtr->flags |= CONSOLE_ASYNC; } else { - infoPtr->flags &= ~CONSOLE_ASYNC; + infoPtr->flags &= ~(CONSOLE_ASYNC); } return 0; } @@ -506,84 +483,6 @@ 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. @@ -602,10 +501,13 @@ ConsoleCloseProc( ClientData instanceData, /* Pointer to ConsoleInfo structure. */ Tcl_Interp *interp) /* For error reporting. */ { - ConsoleInfo *consolePtr = instanceData; - int errorCode = 0; + ConsoleInfo *consolePtr = (ConsoleInfo *) instanceData; + int errorCode; 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 @@ -613,8 +515,49 @@ ConsoleCloseProc( * trying to read from the console. */ - if (consolePtr->reader.thread) { - StopChannelThread(&consolePtr->reader); + 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; } consolePtr->validMask &= ~TCL_READABLE; @@ -624,20 +567,62 @@ ConsoleCloseProc( * should be no pending write operations. */ - if (consolePtr->writer.thread) { + if (consolePtr->writeThread) { if (consolePtr->toWrite) { /* * We only need to wait if there is something to write. This may - * prevent infinite wait on exit. [Python Bug 216289] + * 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. */ - WaitForSingleObject(consolePtr->writer.readyEvent, INFINITE); + 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); + } } - StopChannelThread(&consolePtr->writer); + CloseHandle(consolePtr->writeThread); + CloseHandle(consolePtr->writable); + CloseHandle(consolePtr->startWriter); + CloseHandle(consolePtr->stopWriter); + consolePtr->writeThread = NULL; } 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 @@ -663,7 +648,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; } @@ -672,7 +657,7 @@ ConsoleCloseProc( ckfree(consolePtr->writeBuf); consolePtr->writeBuf = 0; } - ckfree(consolePtr); + ckfree((char*) consolePtr); return errorCode; } @@ -703,7 +688,7 @@ ConsoleInputProc( * buffer? */ int *errorCode) /* Where to store error code. */ { - ConsoleInfo *infoPtr = instanceData; + ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData; DWORD count, bytesRead = 0; int result; @@ -738,7 +723,7 @@ ConsoleInputProc( bytesRead = infoPtr->bytesRead - infoPtr->offset; /* - * Reset the buffer. + * Reset the buffer */ infoPtr->readFlags &= ~CONSOLE_BUFFERED; @@ -754,8 +739,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; } @@ -784,17 +769,16 @@ 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 = instanceData; - ConsoleThreadInfo *threadInfo = &infoPtr->reader; + ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData; DWORD bytesWritten, timeout; *errorCode = 0; timeout = (infoPtr->flags & CONSOLE_ASYNC) ? 0 : INFINITE; - if (WaitForSingleObject(threadInfo->readyEvent,timeout) == WAIT_TIMEOUT) { + if (WaitForSingleObject(infoPtr->writable, timeout) == WAIT_TIMEOUT) { /* * The writer thread is blocked waiting for a write to complete and * the channel is in non-blocking mode. @@ -829,12 +813,12 @@ ConsoleOutputProc( ckfree(infoPtr->writeBuf); } infoPtr->writeBufLen = toWrite; - infoPtr->writeBuf = ckalloc(toWrite); + infoPtr->writeBuf = ckalloc((size_t)toWrite); } - memcpy(infoPtr->writeBuf, buf, (size_t) toWrite); + memcpy(infoPtr->writeBuf, buf, (size_t)toWrite); infoPtr->toWrite = toWrite; - ResetEvent(threadInfo->readyEvent); - SetEvent(threadInfo->startEvent); + ResetEvent(infoPtr->writable); + SetEvent(infoPtr->startWriter); bytesWritten = toWrite; } else { /* @@ -842,8 +826,9 @@ 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; } @@ -882,7 +867,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); @@ -901,7 +886,7 @@ ConsoleEventProc( for (infoPtr = tsdPtr->firstConsolePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (consoleEvPtr->infoPtr == infoPtr) { - infoPtr->flags &= ~CONSOLE_PENDING; + infoPtr->flags &= ~(CONSOLE_PENDING); break; } } @@ -922,8 +907,7 @@ ConsoleEventProc( mask = 0; if (infoPtr->watchMask & TCL_WRITABLE) { - if (WaitForSingleObject(infoPtr->writer.readyEvent, - 0) != WAIT_TIMEOUT) { + if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) { mask = TCL_WRITABLE; } } @@ -970,7 +954,7 @@ ConsoleWatchProc( * TCL_EXCEPTION. */ { ConsoleInfo **nextPtrPtr, *ptr; - ConsoleInfo *infoPtr = instanceData; + ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData; int oldMask = infoPtr->watchMask; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -982,7 +966,6 @@ ConsoleWatchProc( infoPtr->watchMask = mask & infoPtr->validMask; if (infoPtr->watchMask) { Tcl_Time blockTime = { 0, 0 }; - if (!oldMask) { infoPtr->nextPtr = tsdPtr->firstConsolePtr; tsdPtr->firstConsolePtr = infoPtr; @@ -1025,12 +1008,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 = instanceData; + ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData; - *handlePtr = infoPtr->handle; + *handlePtr = (ClientData) infoPtr->handle; return TCL_OK; } @@ -1063,7 +1046,6 @@ WaitForRead( { DWORD timeout, count; HANDLE *handle = infoPtr->handle; - ConsoleThreadInfo *threadInfo = &infoPtr->reader; INPUT_RECORD input; while (1) { @@ -1072,8 +1054,7 @@ WaitForRead( */ timeout = blocking ? INFINITE : 0; - if (WaitForSingleObject(threadInfo->readyEvent, - timeout) == WAIT_TIMEOUT) { + if (WaitForSingleObject(infoPtr->readable, timeout) == WAIT_TIMEOUT) { /* * The reader thread is blocked waiting for data and the channel * is in non-blocking mode. @@ -1132,8 +1113,8 @@ WaitForRead( * There wasn't any data available, so reset the thread and try again. */ - ResetEvent(threadInfo->readyEvent); - SetEvent(threadInfo->startEvent); + ResetEvent(infoPtr->readable); + SetEvent(infoPtr->startReader); } } @@ -1160,18 +1141,14 @@ static DWORD WINAPI ConsoleReaderThread( LPVOID arg) { - ConsoleInfo *infoPtr = arg; + ConsoleInfo *infoPtr = (ConsoleInfo *)arg; HANDLE *handle = infoPtr->handle; - ConsoleThreadInfo *threadInfo = &infoPtr->reader; DWORD waitResult; HANDLE wEvents[2]; - /* - * The first event takes precedence. - */ - - wEvents[0] = threadInfo->stopEvent; - wEvents[1] = threadInfo->startEvent; + /* The first event takes precedence. */ + wEvents[0] = infoPtr->stopReader; + wEvents[1] = infoPtr->startReader; for (;;) { /* @@ -1194,7 +1171,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. @@ -1202,9 +1179,10 @@ ConsoleReaderThread( infoPtr->readFlags |= CONSOLE_BUFFERED; } else { - DWORD err = GetLastError(); + DWORD err; + err = GetLastError(); - if (err == (DWORD) EOF) { + if (err == (DWORD)EOF) { infoPtr->readFlags = CONSOLE_EOF; } } @@ -1214,7 +1192,7 @@ ConsoleReaderThread( * waking up the notifier thread. */ - SetEvent(threadInfo->readyEvent); + SetEvent(infoPtr->readable); /* * Alert the foreground thread. Note that we need to treat this like a @@ -1228,7 +1206,6 @@ ConsoleReaderThread( * TIP #218. When in flight ignore the event, no one will receive * it anyway. */ - Tcl_ThreadAlert(infoPtr->threadId); } Tcl_MutexUnlock(&consoleMutex); @@ -1260,19 +1237,16 @@ static DWORD WINAPI ConsoleWriterThread( LPVOID arg) { - ConsoleInfo *infoPtr = arg; + + ConsoleInfo *infoPtr = (ConsoleInfo *)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] = threadInfo->stopEvent; - wEvents[1] = threadInfo->startEvent; + /* The first event takes precedence. */ + wEvents[0] = infoPtr->stopWriter; + wEvents[1] = infoPtr->startWriter; for (;;) { /* @@ -1298,13 +1272,14 @@ 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; } /* @@ -1312,7 +1287,7 @@ ConsoleWriterThread( * waking up the notifier thread. */ - SetEvent(threadInfo->readyEvent); + SetEvent(infoPtr->writable); /* * Alert the foreground thread. Note that we need to treat this like a @@ -1348,7 +1323,7 @@ ConsoleWriterThread( * Returns the new channel, or NULL. * * Side effects: - * May open the channel. + * May open the channel * *---------------------------------------------------------------------- */ @@ -1361,7 +1336,7 @@ TclWinOpenConsoleChannel( { char encoding[4 + TCL_INTEGER_SPACE]; ConsoleInfo *infoPtr; - DWORD modes; + DWORD id, modes; ConsoleInit(); @@ -1369,7 +1344,7 @@ TclWinOpenConsoleChannel( * See if a channel with this handle already exists. */ - infoPtr = ckalloc(sizeof(ConsoleInfo)); + infoPtr = (ConsoleInfo *) ckalloc((unsigned) sizeof(ConsoleInfo)); memset(infoPtr, 0, sizeof(ConsoleInfo)); infoPtr->validMask = permissions; @@ -1386,10 +1361,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, - infoPtr, permissions); + (ClientData) infoPtr, permissions); if (permissions & TCL_READABLE) { /* @@ -1402,11 +1377,22 @@ TclWinOpenConsoleChannel( modes &= ~(ENABLE_WINDOW_INPUT | ENABLE_MOUSE_INPUT); modes |= ENABLE_LINE_INPUT; SetConsoleMode(infoPtr->handle, modes); - StartChannelThread(infoPtr, &infoPtr->reader, ConsoleReaderThread); + + 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); } if (permissions & TCL_WRITABLE) { - StartChannelThread(infoPtr, &infoPtr->writer, ConsoleWriterThread); + 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); } /* @@ -1416,11 +1402,11 @@ TclWinOpenConsoleChannel( Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto"); Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}"); -#ifdef UNICODE - Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", "unicode"); -#else - Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", encoding); -#endif + if (tclWinProcs->useWide) + Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", "unicode"); + else + Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", encoding); + return infoPtr->channel; } @@ -1445,10 +1431,9 @@ ConsoleThreadActionProc( ClientData instanceData, int action) { - ConsoleInfo *infoPtr = instanceData; + ConsoleInfo *infoPtr = (ConsoleInfo *) 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 ce0b413..eef5caa 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -10,29 +10,11 @@ * 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 @@ -52,7 +34,7 @@ typedef struct RegisteredInterp { struct RegisteredInterp *nextPtr; /* The next interp this application knows * about. */ - TCHAR *name; /* Interpreter's name (malloc-ed). */ + char *name; /* Interpreter's name (malloc-ed). */ Tcl_Obj *handlerPtr; /* The server handler command */ Tcl_Interp *interp; /* The interpreter attached to this name. */ } RegisteredInterp; @@ -97,10 +79,9 @@ 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 TEXT("TclEval") -#define TCL_DDE_EXECUTE_RESULT TEXT("$TCLEVAL$EXECUTE$RESULT") +#define TCL_DDE_SERVICE_NAME "TclEval" +#define TCL_DDE_EXECUTE_RESULT "$TCLEVAL$EXECUTE$RESULT" #define DDE_FLAG_ASYNC 1 #define DDE_FLAG_BINARY 2 @@ -119,7 +100,7 @@ static BOOL CALLBACK DdeEnumWindowsCallback(HWND hwndTarget, LPARAM lParam); static void DdeExitProc(ClientData clientData); static int DdeGetServicesList(Tcl_Interp *interp, - const TCHAR *serviceName, const TCHAR *topicName); + const char *serviceName, const char *topicName); static HDDEDATA CALLBACK DdeServerProc(UINT uType, UINT uFmt, HCONV hConv, HSZ ddeTopic, HSZ ddeItem, HDDEDATA hData, DWORD dwData1, DWORD dwData2); @@ -129,7 +110,7 @@ static void DeleteProc(ClientData clientData); static Tcl_Obj * ExecuteRemoteObject(RegisteredInterp *riPtr, Tcl_Obj *ddeObjectPtr); static int MakeDdeConnection(Tcl_Interp *interp, - const TCHAR *name, HCONV *ddeConvPtr); + const char *name, HCONV *ddeConvPtr); static void SetDdeError(Tcl_Interp *interp); static int DdeObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, @@ -162,16 +143,9 @@ 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, TCL_DDE_VERSION); + return Tcl_PkgProvide(interp, TCL_DDE_PACKAGE_NAME, "1.3.3"); } /* @@ -255,7 +229,7 @@ Initialize(void) ddeIsServer = 1; Tcl_CreateExitHandler(DdeExitProc, NULL); ddeServiceGlobal = DdeCreateStringHandle(ddeInstance, - TCL_DDE_SERVICE_NAME, CP_WINUNICODE); + TCL_DDE_SERVICE_NAME, 0); DdeNameService(ddeInstance, ddeServiceGlobal, 0L, DNS_REGISTER); } else { ddeIsServer = 0; @@ -289,10 +263,10 @@ Initialize(void) *---------------------------------------------------------------------- */ -static const TCHAR * +static const char * DdeSetServerName( Tcl_Interp *interp, - const TCHAR *name, /* The name that will be used to refer to the + const char *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 */ @@ -302,7 +276,7 @@ DdeSetServerName( int suffix, offset; RegisteredInterp *riPtr, *prevPtr; Tcl_DString dString; - const TCHAR *actualName; + const char *actualName; Tcl_Obj *srvListPtr = NULL, **srvPtrPtr = NULL; int n, srvCount = 0, lastSuffix, r = TCL_OK; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -340,7 +314,7 @@ DdeSetServerName( * current interp, but it doesn't have a name. */ - return TEXT(""); + return ""; } /* @@ -361,9 +335,7 @@ DdeSetServerName( &srvPtrPtr); } if (r != TCL_OK) { - Tcl_WinUtfToTChar(Tcl_GetStringResult(interp), -1, &dString); - OutputDebugString((TCHAR *) Tcl_DStringValue(&dString)); - Tcl_DStringFree(&dString); + OutputDebugString(Tcl_GetStringResult(interp)); return NULL; } @@ -380,14 +352,13 @@ DdeSetServerName( lastSuffix = suffix; if (suffix > 1) { if (suffix == 2) { - Tcl_DStringAppend(&dString, (char *)name, _tcslen(name) * sizeof(TCHAR)); - Tcl_DStringAppend(&dString, (char *)TEXT(" #"), 2 * sizeof(TCHAR)); + Tcl_DStringAppend(&dString, name, -1); + Tcl_DStringAppend(&dString, " #", 2); offset = Tcl_DStringLength(&dString); - Tcl_DStringSetLength(&dString, offset + sizeof(TCHAR) * TCL_INTEGER_SPACE); - actualName = (TCHAR *) Tcl_DStringValue(&dString); + Tcl_DStringSetLength(&dString, offset + TCL_INTEGER_SPACE); + actualName = Tcl_DStringValue(&dString); } - _sntprintf((TCHAR *) (Tcl_DStringValue(&dString) + offset), - TCL_INTEGER_SPACE, TEXT("%d"), suffix); + sprintf(Tcl_DStringValue(&dString) + offset, "%d", suffix); } /* @@ -396,41 +367,39 @@ DdeSetServerName( for (n = 0; n < srvCount; ++n) { Tcl_Obj* namePtr; - Tcl_DString ds; Tcl_ListObjIndex(interp, srvPtrPtr[n], 1, &namePtr); - Tcl_WinUtfToTChar(Tcl_GetString(namePtr), -1, &ds); - if (_tcscmp(actualName, (TCHAR *)Tcl_DStringValue(&ds)) == 0) { + if (strcmp(actualName, Tcl_GetString(namePtr)) == 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 = ckalloc(sizeof(RegisteredInterp)); + riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp)); riPtr->interp = interp; - riPtr->name = ckalloc((_tcslen(actualName) + 1) * sizeof(TCHAR)); + riPtr->name = ckalloc((unsigned int) strlen(actualName) + 1); riPtr->nextPtr = tsdPtr->interpListPtr; riPtr->handlerPtr = handlerPtr; if (riPtr->handlerPtr != NULL) { Tcl_IncrRefCount(riPtr->handlerPtr); } tsdPtr->interpListPtr = riPtr; - _tcscpy(riPtr->name, actualName); + strcpy(riPtr->name, actualName); if (Tcl_IsSafe(interp)) { Tcl_ExposeCommand(interp, "dde", "dde"); } Tcl_CreateObjCommand(interp, "dde", DdeObjCmd, - riPtr, DeleteProc); + (ClientData) riPtr, DeleteProc); if (Tcl_IsSafe(interp)) { Tcl_HideCommand(interp, "dde", "dde"); } @@ -559,7 +528,6 @@ 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; } @@ -639,7 +607,7 @@ DdeServerProc( Tcl_DString dString; int len; DWORD dlen; - TCHAR *utilString; + char *utilString; Tcl_Obj *ddeObjectPtr; HDDEDATA ddeReturn = NULL; RegisteredInterp *riPtr; @@ -653,16 +621,16 @@ DdeServerProc( * sure we have a valid topic. */ - len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, CP_WINUNICODE); + len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0); Tcl_DStringInit(&dString); - Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); - utilString = (TCHAR *) Tcl_DStringValue(&dString); + Tcl_DStringSetLength(&dString, len); + utilString = Tcl_DStringValue(&dString); DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1, - CP_WINUNICODE); + CP_WINANSI); for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; riPtr = riPtr->nextPtr) { - if (_tcsicmp(utilString, riPtr->name) == 0) { + if (stricmp(utilString, riPtr->name) == 0) { Tcl_DStringFree(&dString); return (HDDEDATA) TRUE; } @@ -678,16 +646,16 @@ DdeServerProc( * result to return in an XTYP_REQUEST. */ - len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, CP_WINUNICODE); + len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0); Tcl_DStringInit(&dString); - Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); - utilString = (TCHAR *) Tcl_DStringValue(&dString); + Tcl_DStringSetLength(&dString, len); + utilString = Tcl_DStringValue(&dString); DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1, - CP_WINUNICODE); + CP_WINANSI); for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; riPtr = riPtr->nextPtr) { - if (_tcsicmp(riPtr->name, utilString) == 0) { - convPtr = ckalloc(sizeof(Conversation)); + if (stricmp(riPtr->name, utilString) == 0) { + convPtr = (Conversation *) ckalloc(sizeof(Conversation)); convPtr->nextPtr = tsdPtr->currentConversations; convPtr->returnPackagePtr = NULL; convPtr->hConv = hConv; @@ -717,7 +685,7 @@ DdeServerProc( if (convPtr->returnPackagePtr != NULL) { Tcl_DecrRefCount(convPtr->returnPackagePtr); } - ckfree(convPtr); + ckfree((char *) convPtr); break; } } @@ -745,20 +713,20 @@ DdeServerProc( if (convPtr != NULL) { char *returnString; - len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE); + len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINANSI); Tcl_DStringInit(&dString); - Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); - utilString = (TCHAR *) Tcl_DStringValue(&dString); + Tcl_DStringSetLength(&dString, len); + utilString = Tcl_DStringValue(&dString); DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1, - CP_WINUNICODE); - if (_tcsicmp(utilString, TCL_DDE_EXECUTE_RESULT) == 0) { + CP_WINANSI); + if (stricmp(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 = sizeof(TCHAR) * len + 1; + len = 2 * len + 1; } ddeReturn = DdeCreateDataHandle(ddeInstance, (BYTE *)returnString, (DWORD) len+1, 0, ddeItem, uFmt, 0); @@ -766,11 +734,8 @@ DdeServerProc( if (Tcl_IsSafe(convPtr->riPtr->interp)) { ddeReturn = NULL; } else { - Tcl_DString ds; - Tcl_Obj *variableObjPtr; - Tcl_WinTCharToUtf(utilString, -1, &ds); - variableObjPtr = Tcl_GetVar2Ex( - convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL, + Tcl_Obj *variableObjPtr = Tcl_GetVar2Ex( + convPtr->riPtr->interp, utilString, NULL, TCL_GLOBAL_ONLY); if (variableObjPtr != NULL) { if (uFmt == CF_TEXT) { @@ -779,7 +744,7 @@ DdeServerProc( } else { returnString = (char *) Tcl_GetUnicodeFromObj( variableObjPtr, &len); - len = sizeof(TCHAR) * len + 1; + len = 2 * len + 1; } ddeReturn = DdeCreateDataHandle(ddeInstance, (BYTE *)returnString, (DWORD) len+1, 0, ddeItem, @@ -787,60 +752,12 @@ 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 @@ -848,7 +765,7 @@ DdeServerProc( */ Tcl_Obj *returnPackagePtr; - char *string; + Tcl_UniChar *uniStr; for (convPtr = tsdPtr->currentConversations; (convPtr != NULL) && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) { @@ -861,21 +778,21 @@ DdeServerProc( return (HDDEDATA) DDE_FNOTPROCESSED; } - utilString = (TCHAR *) DdeAccessData(hData, &dlen); - string = (char *) utilString; + utilString = (char *) DdeAccessData(hData, &dlen); + uniStr = (Tcl_UniChar *) utilString; if (!dlen) { /* Empty binary array. */ ddeObjectPtr = Tcl_NewObj(); - } else if ((dlen & 1) || utilString[(dlen>>1)-1]) { + } else if ((dlen & 1) || uniStr[(dlen>>1)-1]) { /* Cannot be unicode, so assume utf-8 */ - if (!string[dlen-1]) { + if (!utilString[dlen-1]) { dlen--; } - ddeObjectPtr = Tcl_NewStringObj(string, dlen); + ddeObjectPtr = Tcl_NewStringObj(utilString, dlen); } else { /* unicode */ dlen >>= 1; - ddeObjectPtr = Tcl_NewUnicodeObj((Tcl_UniChar *)utilString, dlen - 1); + ddeObjectPtr = Tcl_NewUnicodeObj(uniStr, dlen - 1); } Tcl_IncrRefCount(ddeObjectPtr); DdeUnaccessData(hData); @@ -928,9 +845,9 @@ DdeServerProc( for (i = 0, riPtr = tsdPtr->interpListPtr; i < numItems; i++, riPtr = riPtr->nextPtr) { returnPtr[i].hszSvc = DdeCreateStringHandle(ddeInstance, - TCL_DDE_SERVICE_NAME, CP_WINUNICODE); + TCL_DDE_SERVICE_NAME, CP_WINANSI); returnPtr[i].hszTopic = DdeCreateStringHandle(ddeInstance, - riPtr->name, CP_WINUNICODE); + riPtr->name, CP_WINANSI); } returnPtr[i].hszSvc = NULL; returnPtr[i].hszTopic = NULL; @@ -988,14 +905,14 @@ DdeExitProc( static int MakeDdeConnection( Tcl_Interp *interp, /* Used to report errors. */ - const TCHAR *name, /* The connection to use. */ + const char *name, /* The connection to use. */ HCONV *ddeConvPtr) { HSZ ddeTopic, ddeService; HCONV ddeConv; - ddeService = DdeCreateStringHandle(ddeInstance, TCL_DDE_SERVICE_NAME, CP_WINUNICODE); - ddeTopic = DdeCreateStringHandle(ddeInstance, name, CP_WINUNICODE); + ddeService = DdeCreateStringHandle(ddeInstance, TCL_DDE_SERVICE_NAME, 0); + ddeTopic = DdeCreateStringHandle(ddeInstance, name, 0); ddeConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); DdeFreeStringHandle(ddeInstance, ddeService); @@ -1003,13 +920,8 @@ MakeDdeConnection( if (ddeConv == (HCONV) NULL) { if (interp != 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); + Tcl_AppendResult(interp, "no registered server named \"", + name, "\"", NULL); } return TCL_ERROR; } @@ -1043,8 +955,8 @@ DdeCreateClient( struct DdeEnumServices *es) { WNDCLASSEX wc; - static const TCHAR *szDdeClientClassName = TEXT("TclEval client class"); - static const TCHAR *szDdeClientWindowName = TEXT("TclEval client window"); + static const char *szDdeClientClassName = "TclEval client class"; + static const char *szDdeClientWindowName = "TclEval client window"; memset(&wc, 0, sizeof(wc)); wc.cbSize = sizeof(wc); @@ -1099,8 +1011,7 @@ DdeServicesOnAck( ATOM service = (ATOM)LOWORD(lParam); ATOM topic = (ATOM)HIWORD(lParam); struct DdeEnumServices *es; - TCHAR sz[255]; - Tcl_DString dString; + char sz[255]; #ifdef _WIN64 es = (struct DdeEnumServices *) GetWindowLongPtr(hwnd, GWLP_USERDATA); @@ -1114,13 +1025,9 @@ DdeServicesOnAck( Tcl_Obj *resultPtr = Tcl_GetObjResult(es->interp); GlobalGetAtomName(service, sz, 255); - Tcl_WinTCharToUtf(sz, -1, &dString); - Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), -1)); - Tcl_DStringFree(&dString); + Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(sz, -1)); GlobalGetAtomName(topic, sz, 255); - Tcl_WinTCharToUtf(sz, -1, &dString); - Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), -1)); - Tcl_DStringFree(&dString); + Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(sz, -1)); /* * Adding the hwnd as a third list element provides a unique @@ -1167,8 +1074,8 @@ DdeEnumWindowsCallback( static int DdeGetServicesList( Tcl_Interp *interp, - const TCHAR *serviceName, - const TCHAR *topicName) + const char *serviceName, + const char *topicName) { struct DdeEnumServices es; @@ -1215,30 +1122,25 @@ static void SetDdeError( Tcl_Interp *interp) /* The interp to put the message in. */ { - const char *errorMessage, *errorCode; + const char *errorMessage; 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); } /* @@ -1265,29 +1167,23 @@ DdeObjCmd( int objc, /* Number of arguments */ Tcl_Obj *const *objv) /* The arguments */ { - static const char *const ddeCommands[] = { + static const char *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 *const ddeSrvOptions[] = { + static const char *ddeSrvOptions[] = { "-force", "-handler", "--", NULL }; enum DdeSrvOptions { DDE_SERVERNAME_EXACT, DDE_SERVERNAME_HANDLER, DDE_SERVERNAME_LAST, }; - static const char *const ddeExecOptions[] = { - "-async", "-binary", NULL - }; - enum DdeExecOptions { - DDE_EXEC_ASYNC, DDE_EXEC_BINARY - }; - static const char *const ddeEvalOptions[] = { + static const char *ddeExecOptions[] = { "-async", NULL }; - static const char *const ddeReqOptions[] = { + static const char *ddeReqOptions[] = { "-binary", NULL }; @@ -1296,8 +1192,7 @@ DdeObjCmd( HSZ ddeService = NULL, ddeTopic = NULL, ddeItem = NULL, ddeCookie = NULL; HDDEDATA ddeData = NULL, ddeItemData = NULL, ddeReturn; HCONV hConv = NULL; - const TCHAR *serviceName = NULL, *topicName = NULL; - const char *string; + const char *serviceName = NULL, *topicName = NULL, *string; DWORD ddeResult; Tcl_Obj *objPtr, *handlerPtr = NULL; @@ -1364,53 +1259,38 @@ DdeObjCmd( if (objc == 5) { firstArg = 2; 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; - } + } else if (objc == 6) { + if (Tcl_GetIndexFromObj(NULL, objv[2], ddeExecOptions, "option", 0, + &argIndex) == TCL_OK) { + flags |= DDE_FLAG_ASYNC; + firstArg = 3; + break; } - break; } /* otherwise... */ - wrongDdeExecuteArgs: Tcl_WrongNumArgs(interp, 2, objv, - "?-async? ?-binary? serviceName topicName value"); + "?-async? serviceName topicName value"); return TCL_ERROR; case DDE_POKE: - 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; + if (objc != 6) { + Tcl_WrongNumArgs(interp, 2, objv, + "serviceName topicName item value"); + return TCL_ERROR; } - - /* - * Otherwise... - */ - - Tcl_WrongNumArgs(interp, 2, objv, - "?-binary? serviceName topicName item value"); - return TCL_ERROR; + firstArg = 2; + break; case DDE_REQUEST: if (objc == 5) { firstArg = 2; break; - } else if ((objc == 6) && (Tcl_GetIndexFromObj(NULL, objv[2], - ddeReqOptions, "option", 0, &argIndex) == TCL_OK)) { - flags |= DDE_FLAG_BINARY; - firstArg = 3; - 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; + } } /* @@ -1434,7 +1314,7 @@ DdeObjCmd( return TCL_ERROR; } else { firstArg = 2; - if (Tcl_GetIndexFromObj(NULL, objv[2], ddeEvalOptions, "option", + if (Tcl_GetIndexFromObj(NULL, objv[2], ddeExecOptions, "option", 0, &argIndex) == TCL_OK) { if (objc < 5) { goto wrongDdeEvalArgs; @@ -1449,11 +1329,7 @@ DdeObjCmd( Initialize(); if (firstArg != 1) { -#ifdef UNICODE - serviceName = Tcl_GetUnicodeFromObj(objv[firstArg], &length); -#else serviceName = Tcl_GetStringFromObj(objv[firstArg], &length); -#endif } else { length = 0; } @@ -1462,20 +1338,16 @@ DdeObjCmd( serviceName = NULL; } else if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) { ddeService = DdeCreateStringHandle(ddeInstance, (void *) serviceName, - CP_WINUNICODE); + CP_WINANSI); } 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_WINUNICODE); + CP_WINANSI); } } @@ -1484,11 +1356,7 @@ 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); } @@ -1496,21 +1364,12 @@ DdeObjCmd( case DDE_EXECUTE: { int dataLength; - const Tcl_UniChar *dataString; + BYTE *dataString = (BYTE *) Tcl_GetStringFromObj( + objv[firstArg + 2], &dataLength); - 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) { + if (dataLength == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("cannot execute null data", -1)); - Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL); result = TCL_ERROR; break; } @@ -1524,16 +1383,16 @@ DdeObjCmd( break; } - ddeData = DdeCreateDataHandle(ddeInstance, (BYTE *) dataString, - (DWORD) dataLength, 0, 0, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, 0); + ddeData = DdeCreateDataHandle(ddeInstance, dataString, + (DWORD) dataLength+1, 0, 0, CF_TEXT, 0); if (ddeData != NULL) { if (flags & DDE_FLAG_ASYNC) { DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, hConv, 0, - (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); + CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); DdeAbandonTransaction(ddeInstance, hConv, ddeResult); } else { ddeReturn = DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, - hConv, 0, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_EXECUTE, 30000, NULL); + hConv, 0, CF_TEXT, XTYP_EXECUTE, 30000, NULL); if (ddeReturn == 0) { SetDdeError(interp); result = TCL_ERROR; @@ -1547,18 +1406,12 @@ DdeObjCmd( break; } case DDE_REQUEST: { -#ifdef UNICODE - const TCHAR *itemString = (TCHAR *) Tcl_GetUnicodeFromObj(objv[firstArg + 2], - &length); -#else - const TCHAR *itemString = Tcl_GetStringFromObj(objv[firstArg + 2], + const char *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; } @@ -1571,27 +1424,26 @@ DdeObjCmd( result = TCL_ERROR; } else { Tcl_Obj *returnObjPtr; - ddeItem = DdeCreateStringHandle(ddeInstance, (void *) itemString, - CP_WINUNICODE); + ddeItem = DdeCreateStringHandle(ddeInstance, (void *)itemString, + CP_WINANSI); if (ddeItem != NULL) { ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem, - (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_REQUEST, 5000, NULL); + CF_TEXT, XTYP_REQUEST, 5000, NULL); if (ddeData == NULL) { SetDdeError(interp); result = TCL_ERROR; } else { DWORD tmp; - const Tcl_UniChar *dataString = (const Tcl_UniChar *) DdeAccessData(ddeData, &tmp); + const char *dataString = (const char *) DdeAccessData(ddeData, &tmp); if (flags & DDE_FLAG_BINARY) { returnObjPtr = Tcl_NewByteArrayObj((BYTE *) dataString, (int) tmp); } else { - tmp >>= 1; - if (tmp && !dataString[(tmp-1)]) { + if (tmp && !dataString[tmp-1]) { --tmp; } - returnObjPtr = Tcl_NewUnicodeObj(dataString, + returnObjPtr = Tcl_NewStringObj(dataString, (int) tmp); } DdeUnaccessData(ddeData); @@ -1607,30 +1459,18 @@ DdeObjCmd( break; } case DDE_POKE: { -#ifdef UNICODE - const TCHAR *itemString = (TCHAR *) Tcl_GetUnicodeFromObj(objv[firstArg + 2], - &length); -#else - const TCHAR *itemString = Tcl_GetStringFromObj(objv[firstArg + 2], + const char *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; } - 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; - } + dataString = (BYTE *) Tcl_GetStringFromObj(objv[firstArg + 3], + &length); hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); DdeFreeStringHandle(ddeInstance, ddeService); @@ -1641,10 +1481,10 @@ DdeObjCmd( result = TCL_ERROR; } else { ddeItem = DdeCreateStringHandle(ddeInstance, (void *) itemString, - CP_WINUNICODE); + CP_WINANSI); if (ddeItem != NULL) { - ddeData = DdeClientTransaction(dataString, (DWORD) length, - hConv, ddeItem, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_POKE, 5000, NULL); + ddeData = DdeClientTransaction(dataString, (DWORD) length+1, + hConv, ddeItem, CF_TEXT, XTYP_POKE, 5000, NULL); if (ddeData == NULL) { SetDdeError(interp); result = TCL_ERROR; @@ -1668,7 +1508,6 @@ 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; } @@ -1687,7 +1526,7 @@ DdeObjCmd( for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; riPtr = riPtr->nextPtr) { - if (_tcsicmp(serviceName, riPtr->name) == 0) { + if (stricmp(serviceName, riPtr->name) == 0) { break; } } @@ -1700,9 +1539,9 @@ DdeObjCmd( * server. */ - Tcl_Preserve(riPtr); + Tcl_Preserve((ClientData) riPtr); sendInterp = riPtr->interp; - Tcl_Preserve(sendInterp); + Tcl_Preserve((ClientData) sendInterp); /* * Don't exchange objects between interps. The target interp would @@ -1713,11 +1552,9 @@ DdeObjCmd( */ if (Tcl_IsSafe(riPtr->interp) && riPtr->handlerPtr == NULL) { - 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); + Tcl_SetResult(riPtr->interp, "permission denied: " + "a handler procedure must be defined for use in " + "a safe interp", TCL_STATIC); result = TCL_ERROR; } @@ -1769,8 +1606,8 @@ DdeObjCmd( } Tcl_SetObjResult(interp, Tcl_GetObjResult(sendInterp)); } - Tcl_Release(riPtr); - Tcl_Release(sendInterp); + Tcl_Release((ClientData) riPtr); + Tcl_Release((ClientData) sendInterp); } else { /* * This is a non-local request. Send the script to the server and @@ -1780,31 +1617,31 @@ DdeObjCmd( if (MakeDdeConnection(interp, serviceName, &hConv) != TCL_OK) { invalidServerResponse: Tcl_SetObjResult(interp, - Tcl_NewStringObj("invalid data returned from server", -1)); - Tcl_SetErrorCode(interp, "TCL", "DDE", "BAD_RESPONSE", NULL); + Tcl_NewStringObj("invalid data returned from server", + -1)); result = TCL_ERROR; goto cleanup; } objPtr = Tcl_ConcatObj(objc, objv); - string = (const char *) Tcl_GetUnicodeFromObj(objPtr, &length); + string = Tcl_GetStringFromObj(objPtr, &length); ddeItemData = DdeCreateDataHandle(ddeInstance, - (BYTE *) string, (DWORD) 2*length+2, 0, 0, CF_UNICODETEXT, 0); + (BYTE *) string, (DWORD) length+1, 0, 0, CF_TEXT, 0); if (flags & DDE_FLAG_ASYNC) { ddeData = DdeClientTransaction((LPBYTE) ddeItemData, 0xFFFFFFFF, hConv, 0, - CF_UNICODETEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); + CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); DdeAbandonTransaction(ddeInstance, hConv, ddeResult); } else { ddeData = DdeClientTransaction((LPBYTE) ddeItemData, 0xFFFFFFFF, hConv, 0, - CF_UNICODETEXT, XTYP_EXECUTE, 30000, NULL); + CF_TEXT, XTYP_EXECUTE, 30000, NULL); if (ddeData != 0) { ddeCookie = DdeCreateStringHandle(ddeInstance, - TCL_DDE_EXECUTE_RESULT, CP_WINUNICODE); + TCL_DDE_EXECUTE_RESULT, CP_WINANSI); ddeData = DdeClientTransaction(NULL, 0, hConv, ddeCookie, - CF_UNICODETEXT, XTYP_REQUEST, 30000, NULL); + CF_TEXT, XTYP_REQUEST, 30000, NULL); } } @@ -1813,12 +1650,10 @@ 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 @@ -1831,11 +1666,10 @@ DdeObjCmd( resultPtr = Tcl_NewObj(); length = DdeGetData(ddeData, NULL, 0, 0); - ddeDataString = ckalloc(length); - DdeGetData(ddeData, (BYTE *) ddeDataString, (DWORD) length, 0); - length = (length >> 1) - 1; - resultPtr = Tcl_NewUnicodeObj(ddeDataString, length); - ckfree(ddeDataString); + Tcl_SetObjLength(resultPtr, length); + string = Tcl_GetString(resultPtr); + DdeGetData(ddeData, (BYTE *) string, (DWORD) length, 0); + Tcl_SetObjLength(resultPtr, (int) strlen(string)); if (Tcl_ListObjIndex(NULL, resultPtr, 0, &objPtr) != TCL_OK) { Tcl_DecrRefCount(resultPtr); diff --git a/win/tclWinError.c b/win/tclWinError.c index 49eeed3..a74d2e2 100644 --- a/win/tclWinError.c +++ b/win/tclWinError.c @@ -11,11 +11,13 @@ */ #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 */ @@ -291,8 +293,8 @@ static const unsigned char errorTable[] = { * errno errors. */ -static const unsigned char wsaErrorTable[] = { - EAGAIN, /* WSAEWOULDBLOCK */ +static CONST int wsaErrorTable[] = { + EWOULDBLOCK, /* WSAEWOULDBLOCK */ EINPROGRESS, /* WSAEINPROGRESS */ EALREADY, /* WSAEALREADY */ ENOTSOCK, /* WSAENOTSOCK */ @@ -362,62 +364,39 @@ TclWinConvertError( Tcl_SetErrno(errorTable[errCode]); } } - -#ifdef __CYGWIN__ + /* *---------------------------------------------------------------------- * - * tclWinDebugPanic -- + * TclWinConvertWSAError -- * - * Display a message. If a debugger is present, present it directly to - * the debugger, otherwise send it to stderr. + * This routine converts a WinSock error into an errno value. * * Results: * None. * * Side effects: - * None. + * Sets the errno global variable. * *---------------------------------------------------------------------- */ void -tclWinDebugPanic( - const char *format, ...) +TclWinConvertWSAError( + DWORD errCode) /* Win32 error code. */ { -#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)); + 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]); } - OutputDebugStringW(msgString); } else { - vfprintf(stderr, format, argList); - fprintf(stderr, "\n"); - fflush(stderr); + Tcl_SetErrno(errorTable[errCode]); } -# 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 ac88861..d918b4a 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 *const tclpFileAttrStrings[] = { +CONST char *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" (MoveFile) + [moveFile] "r" (tclWinProcs->moveFileProc) : "%eax", "%ebx", "%ecx", "%edx", "memory" ); @@ -286,7 +286,7 @@ DoRenameFile( #ifndef HAVE_NO_SEH __try { #endif - if ((*MoveFile)(nativeSrc, nativeDst) != FALSE) { + if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) { retval = TCL_OK; } #ifndef HAVE_NO_SEH @@ -300,10 +300,10 @@ DoRenameFile( TclWinConvertError(GetLastError()); - srcAttr = GetFileAttributes(nativeSrc); - dstAttr = GetFileAttributes(nativeDst); + srcAttr = (*tclWinProcs->getFileAttributesProc)(nativeSrc); + dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst); if (srcAttr == 0xffffffff) { - if (GetFullPathName(nativeSrc, 0, NULL, + if ((*tclWinProcs->getFullPathNameProc)(nativeSrc, 0, NULL, NULL) >= MAX_PATH) { errno = ENAMETOOLONG; return TCL_ERROR; @@ -311,7 +311,7 @@ DoRenameFile( srcAttr = 0; } if (dstAttr == 0xffffffff) { - if (GetFullPathName(nativeDst, 0, NULL, + if ((*tclWinProcs->getFullPathNameProc)(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; - TCHAR nativeSrcPath[MAX_PATH]; - TCHAR nativeDstPath[MAX_PATH]; + WCHAR nativeSrcPath[MAX_PATH]; + WCHAR nativeDstPath[MAX_PATH]; Tcl_DString srcString, dstString; - const char *src, *dst; + CONST char *src, *dst; - size = GetFullPathName(nativeSrc, MAX_PATH, + size = (*tclWinProcs->getFullPathNameProc)(nativeSrc, MAX_PATH, nativeSrcPath, &nativeSrcRest); if ((size == 0) || (size > MAX_PATH)) { return TCL_ERROR; } - size = GetFullPathName(nativeDst, MAX_PATH, + size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH, nativeDstPath, &nativeDstRest); if ((size == 0) || (size > MAX_PATH)) { return TCL_ERROR; } - CharLower(nativeSrcPath); - CharLower(nativeDstPath); + (*tclWinProcs->charLowerProc)((TCHAR *) nativeSrcPath); + (*tclWinProcs->charLowerProc)((TCHAR *) nativeDstPath); - src = Tcl_WinTCharToUtf(nativeSrcPath, -1, &srcString); - dst = Tcl_WinTCharToUtf(nativeDstPath, -1, &dstString); + src = Tcl_WinTCharToUtf((TCHAR *) nativeSrcPath, -1, &srcString); + dst = Tcl_WinTCharToUtf((TCHAR *) nativeDstPath, -1, &dstString); /* * Check whether the destination path is actually inside the @@ -395,8 +395,8 @@ DoRenameFile( Tcl_SetErrno(EXDEV); } - ckfree(srcArgv); - ckfree(dstArgv); + ckfree((char *) srcArgv); + ckfree((char *) dstArgv); } /* @@ -427,7 +427,7 @@ DoRenameFile( * directory back, for completeness. */ - if (MoveFile(nativeSrc, + if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) { return TCL_OK; } @@ -438,8 +438,8 @@ DoRenameFile( */ TclWinConvertError(GetLastError()); - CreateDirectory(nativeDst, NULL); - SetFileAttributes(nativeDst, dstAttr); + (*tclWinProcs->createDirectoryProc)(nativeDst, NULL); + (*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr); if (Tcl_GetErrno() == EACCES) { /* * Decode the EACCES to a more meaningful error. @@ -466,20 +466,22 @@ DoRenameFile( TCHAR *nativeRest, *nativeTmp, *nativePrefix; int result, size; - TCHAR tempBuf[MAX_PATH]; + WCHAR tempBuf[MAX_PATH]; - size = GetFullPathName(nativeDst, MAX_PATH, + size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH, tempBuf, &nativeRest); if ((size == 0) || (size > MAX_PATH) || (nativeRest == NULL)) { return TCL_ERROR; } nativeTmp = (TCHAR *) tempBuf; - nativeRest[0] = L'\0'; + ((char *) nativeRest)[0] = '\0'; + ((char *) nativeRest)[1] = '\0'; /* In case it's Unicode. */ result = TCL_ERROR; - nativePrefix = (TCHAR *) L"tclr"; - if (GetTempFileName(nativeTmp, nativePrefix, - 0, tempBuf) != 0) { + nativePrefix = (tclWinProcs->useWide) + ? (TCHAR *) L"tclr" : (TCHAR *) "tclr"; + if ((*tclWinProcs->getTempFileNameProc)(nativeTmp, + nativePrefix, 0, tempBuf) != 0) { /* * Strictly speaking, need the following DeleteFile and * MoveFile to be joined as an atomic operation so no @@ -487,16 +489,19 @@ DoRenameFile( * same temp file. */ - nativeTmp = tempBuf; - DeleteFile(nativeTmp); - if (MoveFile(nativeDst, nativeTmp) != FALSE) { - if (MoveFile(nativeSrc, nativeDst) != FALSE) { - SetFileAttributes(nativeTmp, FILE_ATTRIBUTE_NORMAL); - DeleteFile(nativeTmp); + 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); return TCL_OK; } else { - DeleteFile(nativeDst); - MoveFile(nativeTmp, nativeDst); + (*tclWinProcs->deleteFileProc)(nativeDst); + (*tclWinProcs->moveFileProc)(nativeTmp, nativeDst); } } @@ -559,8 +564,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; @@ -663,7 +668,7 @@ DoCopyFile( [registration] "m" (registration), [nativeDst] "m" (nativeDst), [nativeSrc] "m" (nativeSrc), - [copyFile] "r" (CopyFile) + [copyFile] "r" (tclWinProcs->copyFileProc) : "%eax", "%ebx", "%ecx", "%edx", "memory" ); @@ -674,7 +679,7 @@ DoCopyFile( #ifndef HAVE_NO_SEH __try { #endif - if (CopyFile(nativeSrc, nativeDst, 0) != FALSE) { + if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) { retval = TCL_OK; } #ifndef HAVE_NO_SEH @@ -694,8 +699,8 @@ DoCopyFile( if (Tcl_GetErrno() == EACCES) { DWORD srcAttr, dstAttr; - srcAttr = GetFileAttributes(nativeSrc); - dstAttr = GetFileAttributes(nativeDst); + srcAttr = (*tclWinProcs->getFileAttributesProc)(nativeSrc); + dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst); if (srcAttr != 0xffffffff) { if (dstAttr == 0xffffffff) { dstAttr = 0; @@ -711,9 +716,9 @@ DoCopyFile( Tcl_SetErrno(EISDIR); } if (dstAttr & FILE_ATTRIBUTE_READONLY) { - SetFileAttributes(nativeDst, + (*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr & ~((DWORD)FILE_ATTRIBUTE_READONLY)); - if (CopyFile(nativeSrc, nativeDst, + if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) { return TCL_OK; } @@ -724,7 +729,7 @@ DoCopyFile( */ TclWinConvertError(GetLastError()); - SetFileAttributes(nativeDst, dstAttr); + (*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr); } } } @@ -765,35 +770,34 @@ TclpObjDeleteFile( int TclpDeleteFile( - const void *nativePath) /* Pathname of file to be removed (native). */ + CONST TCHAR *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 (path == NULL || path[0] == '\0') { + if (nativePath == NULL || nativePath[0] == '\0') { Tcl_SetErrno(ENOENT); return TCL_ERROR; } - if (DeleteFile(path) != FALSE) { + if ((*tclWinProcs->deleteFileProc)(nativePath) != FALSE) { return TCL_OK; } TclWinConvertError(GetLastError()); if (Tcl_GetErrno() == EACCES) { - attr = GetFileAttributes(path); + attr = (*tclWinProcs->getFileAttributesProc)(nativePath); if (attr != 0xffffffff) { if (attr & FILE_ATTRIBUTE_DIRECTORY) { if (attr & FILE_ATTRIBUTE_REPARSE_POINT) { /* * It is a symbolic link - remove it. */ - if (TclWinSymLinkDelete(path, 0) == 0) { + if (TclWinSymLinkDelete(nativePath, 0) == 0) { return TCL_OK; } } @@ -807,21 +811,21 @@ TclpDeleteFile( Tcl_SetErrno(EISDIR); } else if (attr & FILE_ATTRIBUTE_READONLY) { - int res = SetFileAttributes(path, - attr & ~((DWORD) FILE_ATTRIBUTE_READONLY)); + int res = (*tclWinProcs->setFileAttributesProc)(nativePath, + attr & ~((DWORD)FILE_ATTRIBUTE_READONLY)); - if ((res != 0) && - (DeleteFile(path) != FALSE)) { + if ((res != 0) && ((*tclWinProcs->deleteFileProc)(nativePath) + != FALSE)) { return TCL_OK; } TclWinConvertError(GetLastError()); if (res != 0) { - SetFileAttributes(path, attr); + (*tclWinProcs->setFileAttributesProc)(nativePath, attr); } } } } else if (Tcl_GetErrno() == ENOENT) { - attr = GetFileAttributes(path); + attr = (*tclWinProcs->getFileAttributesProc)(nativePath); if (attr != 0xffffffff) { if (attr & FILE_ATTRIBUTE_DIRECTORY) { /* @@ -878,11 +882,11 @@ TclpObjCreateDirectory( static int DoCreateDirectory( - const TCHAR *nativePath) /* Pathname of directory to create (native). */ + CONST TCHAR *nativePath) /* Pathname of directory to create (native). */ { - if (CreateDirectory(nativePath, NULL) == 0) { - DWORD error = GetLastError(); - + DWORD error; + if ((*tclWinProcs->createDirectoryProc)(nativePath, NULL) == 0) { + error = GetLastError(); TclWinConvertError(error); return TCL_ERROR; } @@ -1011,12 +1015,13 @@ TclpObjRemoveDirectory( } if (ret != TCL_OK) { - if (Tcl_DStringLength(&ds) > 0) { + int len = Tcl_DStringLength(&ds); + if (len > 0) { if (normPtr != NULL && !strcmp(Tcl_DStringValue(&ds), TclGetString(normPtr))) { *errorPtr = pathPtr; } else { - *errorPtr = TclDStringToObj(&ds); + *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); } Tcl_IncrRefCount(*errorPtr); } @@ -1028,7 +1033,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. */ @@ -1048,7 +1053,7 @@ DoRemoveJustDirectory( goto end; } - attr = GetFileAttributes(nativePath); + attr = (*tclWinProcs->getFileAttributesProc)(nativePath); if (attr & FILE_ATTRIBUTE_REPARSE_POINT) { /* @@ -1062,7 +1067,7 @@ DoRemoveJustDirectory( * Ordinary directory. */ - if (RemoveDirectory(nativePath) != FALSE) { + if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) { return TCL_OK; } } @@ -1070,7 +1075,7 @@ DoRemoveJustDirectory( TclWinConvertError(GetLastError()); if (Tcl_GetErrno() == EACCES) { - attr = GetFileAttributes(nativePath); + attr = (*tclWinProcs->getFileAttributesProc)(nativePath); if (attr != 0xffffffff) { if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) { /* @@ -1094,40 +1099,40 @@ DoRemoveJustDirectory( if (attr & FILE_ATTRIBUTE_READONLY) { attr &= ~FILE_ATTRIBUTE_READONLY; - if (SetFileAttributes(nativePath, + if ((*tclWinProcs->setFileAttributesProc)(nativePath, attr) == FALSE) { goto end; } - if (RemoveDirectory(nativePath) != FALSE) { + if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) { return TCL_OK; } TclWinConvertError(GetLastError()); - SetFileAttributes(nativePath, + (*tclWinProcs->setFileAttributesProc)(nativePath, attr | FILE_ATTRIBUTE_READONLY); } /* - * Windows 95 reports removing a non-empty directory as + * 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_WINDOWS) { - const char *path, *find; + 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; + path = (CONST char *) nativePath; Tcl_DStringInit(&buffer); len = strlen(path); find = Tcl_DStringAppend(&buffer, path, len); if ((len > 0) && (find[len - 1] != '\\')) { - TclDStringAppendLiteral(&buffer, "\\"); + Tcl_DStringAppend(&buffer, "\\", 1); } - find = TclDStringAppendLiteral(&buffer, "*.*"); + find = Tcl_DStringAppend(&buffer, "*.*", 3); handle = FindFirstFileA(find, &data); if (handle != INVALID_HANDLE_VALUE) { while (1) { @@ -1187,7 +1192,7 @@ DoRemoveDirectory( * filled with UTF-8 name of file causing * error. */ { - int res = DoRemoveJustDirectory((const TCHAR *)Tcl_DStringValue(pathPtr), recursive, + int res = DoRemoveJustDirectory(Tcl_DStringValue(pathPtr), recursive, errorPtr); if ((res == TCL_ERROR) && (recursive != 0) && (Tcl_GetErrno() == EEXIST)) { @@ -1241,7 +1246,7 @@ TraverseWinTree( TCHAR *nativeSource, *nativeTarget, *nativeErrfile; int result, found, sourceLen, targetLen = 0, oldSourceLen, oldTargetLen; HANDLE handle; - WIN32_FIND_DATA data; + WIN32_FIND_DATAT data; nativeErrfile = NULL; result = TCL_OK; @@ -1252,7 +1257,7 @@ TraverseWinTree( (targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr)); oldSourceLen = Tcl_DStringLength(sourcePtr); - sourceAttr = GetFileAttributes(nativeSource); + sourceAttr = (*tclWinProcs->getFileAttributesProc)(nativeSource); if (sourceAttr == 0xffffffff) { nativeErrfile = nativeSource; goto end; @@ -1263,7 +1268,7 @@ TraverseWinTree( * Process the symbolic link */ - return traverseProc(nativeSource, nativeTarget, DOTREE_LINK, + return (*traverseProc)(nativeSource, nativeTarget, DOTREE_LINK, errorPtr); } @@ -1272,14 +1277,18 @@ TraverseWinTree( * Process the regular file */ - return traverseProc(nativeSource, nativeTarget, DOTREE_F, errorPtr); + return (*traverseProc)(nativeSource, nativeTarget, DOTREE_F, errorPtr); } - Tcl_DStringAppend(sourcePtr, (char *) TEXT("\\*.*"), 4 * sizeof(TCHAR) + 1); - Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1); + if (tclWinProcs->useWide) { + Tcl_DStringAppend(sourcePtr, (char *) L"\\*.*", 4 * sizeof(WCHAR) + 1); + Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1); + } else { + Tcl_DStringAppend(sourcePtr, "\\*.*", 4); + } nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr); - handle = FindFirstFile(nativeSource, &data); + handle = (*tclWinProcs->findFirstFileProc)(nativeSource, &data); if (handle == INVALID_HANDLE_VALUE) { /* * Can't read directory. @@ -1290,44 +1299,67 @@ TraverseWinTree( goto end; } - Tcl_DStringSetLength(sourcePtr, oldSourceLen + 1); + nativeSource[oldSourceLen + 1] = '\0'; 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 + sizeof(TCHAR); - Tcl_DStringAppend(sourcePtr, (char *) TEXT("\\"), sizeof(TCHAR) + 1); - Tcl_DStringSetLength(sourcePtr, sourceLen); + 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); + } if (targetPtr != NULL) { oldTargetLen = Tcl_DStringLength(targetPtr); targetLen = oldTargetLen; - targetLen += sizeof(TCHAR); - Tcl_DStringAppend(targetPtr, (char *) TEXT("\\"), sizeof(TCHAR) + 1); - Tcl_DStringSetLength(targetPtr, targetLen); + 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); + } } found = 1; - for (; found; found = FindNextFile(handle, &data)) { + for (; found; found = (*tclWinProcs->findNextFileProc)(handle, &data)) { TCHAR *nativeName; int len; - TCHAR *wp = data.cFileName; - if (*wp == '.') { - wp++; + if (tclWinProcs->useWide) { + WCHAR *wp; + + wp = data.w.cFileName; if (*wp == '.') { wp++; + if (*wp == '.') { + wp++; + } + if (*wp == '\0') { + continue; + } } - if (*wp == '\0') { + nativeName = (TCHAR *) data.w.cFileName; + len = wcslen(data.w.cFileName) * sizeof(WCHAR); + } else { + if ((strcmp(data.a.cFileName, ".") == 0) + || (strcmp(data.a.cFileName, "..") == 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. @@ -1372,8 +1404,8 @@ TraverseWinTree( * files in that directory. */ - result = traverseProc((const TCHAR *)Tcl_DStringValue(sourcePtr), - (const TCHAR *)(targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr)), + result = (*traverseProc)(Tcl_DStringValue(sourcePtr), + (targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr)), DOTREE_POSTD, errorPtr); } @@ -1408,8 +1440,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. */ @@ -1427,9 +1459,9 @@ TraversalCopy( break; case DOTREE_PRED: if (DoCreateDirectory(nativeDst) == TCL_OK) { - DWORD attr = GetFileAttributes(nativeSrc); + DWORD attr = (tclWinProcs->getFileAttributesProc)(nativeSrc); - if (SetFileAttributes(nativeDst, + if ((tclWinProcs->setFileAttributesProc)(nativeDst, attr) != FALSE) { return TCL_OK; } @@ -1474,8 +1506,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. */ @@ -1530,8 +1562,8 @@ StatError( * error. */ { TclWinConvertError(GetLastError()); - Tcl_SetObjResult(interp, Tcl_ObjPrintf("could not read \"%s\": %s", - TclGetString(fileName), Tcl_PosixError(interp))); + Tcl_AppendResult(interp, "could not read \"", TclGetString(fileName), + "\": ", Tcl_PosixError(interp), (char *) NULL); } /* @@ -1561,11 +1593,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 = GetFileAttributes(nativeName); + result = (*tclWinProcs->getFileAttributesProc)(nativeName); if (result == 0xffffffff) { StatError(interp, fileName); @@ -1583,7 +1615,7 @@ GetWinFileAttributes( */ int len; - const char *str = Tcl_GetStringFromObj(fileName,&len); + char *str = Tcl_GetStringFromObj(fileName,&len); if (len < 4) { if (len == 0) { @@ -1649,11 +1681,9 @@ ConvertFileNameFormat( if (splitPath == NULL || pathc == 0) { if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "could not read \"%s\": no such file or directory", - Tcl_GetString(fileName))); - errno = ENOENT; - Tcl_PosixError(interp); + Tcl_AppendResult(interp, "could not read \"", + Tcl_GetString(fileName), "\": no such file or directory", + (char *) NULL); } goto cleanup; } @@ -1694,10 +1724,10 @@ ConvertFileNameFormat( Tcl_Obj *tempPath; Tcl_DString ds; Tcl_DString dsTemp; - const TCHAR *nativeName; - const char *tempString; + TCHAR *nativeName; + char *tempString; int tempLen; - WIN32_FIND_DATA data; + WIN32_FIND_DATAT data; HANDLE handle; DWORD attr; @@ -1713,7 +1743,7 @@ ConvertFileNameFormat( tempString = Tcl_GetStringFromObj(tempPath,&tempLen); nativeName = Tcl_WinUtfToTChar(tempString, tempLen, &ds); Tcl_DecrRefCount(tempPath); - handle = FindFirstFile(nativeName, &data); + handle = (*tclWinProcs->findFirstFileProc)(nativeName, &data); if (handle == INVALID_HANDLE_VALUE) { /* * FindFirstFile() doesn't like root directories. We would @@ -1722,7 +1752,7 @@ ConvertFileNameFormat( * root directory */ - attr = GetFileAttributes(nativeName); + attr = (*tclWinProcs->getFileAttributesProc)(nativeName); if ((attr!=0xFFFFFFFF) && (attr & FILE_ATTRIBUTE_DIRECTORY)) { Tcl_DStringFree(&ds); goto simple; @@ -1736,14 +1766,27 @@ ConvertFileNameFormat( } goto cleanup; } - nativeName = data.cAlternateFileName; - if (longShort) { - if (data.cFileName[0] != '\0') { - nativeName = data.cFileName; + 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; + } } } else { - if (data.cAlternateFileName[0] == '\0') { - nativeName = (TCHAR *) data.cFileName; + 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; + } } } @@ -1761,21 +1804,22 @@ ConvertFileNameFormat( Tcl_DStringInit(&dsTemp); Tcl_WinTCharToUtf(nativeName, -1, &dsTemp); - Tcl_DStringFree(&ds); /* * Deal with issues of tildes being absolute. */ if (Tcl_DStringValue(&dsTemp)[0] == '~') { - TclNewLiteralStringObj(tempPath, "./"); + tempPath = Tcl_NewStringObj("./",2); Tcl_AppendToObj(tempPath, Tcl_DStringValue(&dsTemp), Tcl_DStringLength(&dsTemp)); - Tcl_DStringFree(&dsTemp); } else { - tempPath = TclDStringToObj(&dsTemp); + tempPath = Tcl_NewStringObj(Tcl_DStringValue(&dsTemp), + Tcl_DStringLength(&dsTemp)); } Tcl_ListObjReplace(NULL, splitPath, i, 1, 1, &tempPath); + Tcl_DStringFree(&ds); + Tcl_DStringFree(&dsTemp); FindClose(handle); } } @@ -1888,11 +1932,12 @@ SetWinFileAttributes( Tcl_Obj *attributePtr) /* The new value of the attribute. */ { DWORD fileAttributes; - int yesNo, result; - const TCHAR *nativeName; + int yesNo; + int result; + CONST TCHAR *nativeName; nativeName = Tcl_FSGetNativePath(fileName); - fileAttributes = GetFileAttributes(nativeName); + fileAttributes = (*tclWinProcs->getFileAttributesProc)(nativeName); if (fileAttributes == 0xffffffff) { StatError(interp, fileName); @@ -1910,7 +1955,7 @@ SetWinFileAttributes( fileAttributes &= ~(attributeArray[objIndex]); } - if (!SetFileAttributes(nativeName, fileAttributes)) { + if (!(*tclWinProcs->setFileAttributesProc)(nativeName, fileAttributes)) { StatError(interp, fileName); return TCL_ERROR; } @@ -1941,13 +1986,13 @@ CannotSetAttribute( Tcl_Obj *fileName, /* The name of the file. */ Tcl_Obj *attributePtr) /* The new value of the attribute. */ { - 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); + Tcl_AppendResult(interp, "cannot set attribute \"", + tclpFileAttrStrings[objIndex], "\" for file \"", + Tcl_GetString(fileName), "\": attribute is readonly", + (char *) NULL); return TCL_ERROR; } + /* *--------------------------------------------------------------------------- @@ -1965,7 +2010,7 @@ CannotSetAttribute( *--------------------------------------------------------------------------- */ -Tcl_Obj * +Tcl_Obj* TclpObjListVolumes(void) { Tcl_Obj *resultPtr, *elemPtr; diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 8e517d1..676c443 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -16,7 +16,7 @@ #include "tclFileSystem.h" #include <winioctl.h> #include <shlobj.h> -#include <lm.h> /* For TclpGetUserHome(). */ +#include <lmaccess.h> /* For TclpGetUserHome(). */ /* * The number of 100-ns intervals between the Windows system epoch (1601-01-01 @@ -140,6 +140,28 @@ 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. */ @@ -147,6 +169,14 @@ typedef struct { 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: */ @@ -172,7 +202,6 @@ 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, ...); /* *-------------------------------------------------------------------- @@ -190,7 +219,7 @@ WinLink( const TCHAR *linkTargetPath, int linkAction) { - TCHAR tempFileName[MAX_PATH]; + WCHAR tempFileName[MAX_PATH]; TCHAR *tempFilePart; DWORD attr; @@ -198,8 +227,8 @@ WinLink( * Get the full path referenced by the target. */ - if (!GetFullPathName(linkTargetPath, MAX_PATH, tempFileName, - &tempFilePart)) { + if (!(*tclWinProcs->getFullPathNameProc)(linkTargetPath, MAX_PATH, + tempFileName, &tempFilePart)) { /* * Invalid file. */ @@ -212,7 +241,7 @@ WinLink( * Make sure source file doesn't exist. */ - attr = GetFileAttributes(linkSourcePath); + attr = (*tclWinProcs->getFileAttributesProc)(linkSourcePath); if (attr != INVALID_FILE_ATTRIBUTES) { Tcl_SetErrno(EEXIST); return -1; @@ -222,8 +251,8 @@ WinLink( * Get the full path referenced by the source file/directory. */ - if (!GetFullPathName(linkSourcePath, MAX_PATH, tempFileName, - &tempFilePart)) { + if (!(*tclWinProcs->getFullPathNameProc)(linkSourcePath, MAX_PATH, + tempFileName, &tempFilePart)) { /* * Invalid file. */ @@ -236,36 +265,43 @@ WinLink( * Check the target. */ - attr = GetFileAttributes(linkTargetPath); + attr = (*tclWinProcs->getFileAttributesProc)(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 (linkAction & TCL_CREATE_HARD_LINK) { - if (CreateHardLink(linkSourcePath, linkTargetPath, NULL)) { - /* - * Success! - */ + if (tclWinProcs->createHardLinkProc == NULL) { + Tcl_SetErrno(ENOTDIR); + return -1; + } - return 0; + if (linkAction & TCL_CREATE_HARD_LINK) { + if (!(*tclWinProcs->createHardLinkProc)(linkSourcePath, + linkTargetPath, NULL)) { + TclWinConvertError(GetLastError()); + return -1; } + 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 { /* @@ -282,11 +318,12 @@ WinLink( */ Tcl_SetErrno(EISDIR); + return -1; } else { Tcl_SetErrno(ENODEV); + return -1; } } - return -1; } /* @@ -303,7 +340,7 @@ static Tcl_Obj * WinReadLink( const TCHAR *linkSourcePath) { - TCHAR tempFileName[MAX_PATH]; + WCHAR tempFileName[MAX_PATH]; TCHAR *tempFilePart; DWORD attr; @@ -311,8 +348,8 @@ WinReadLink( * Get the full path referenced by the target. */ - if (!GetFullPathName(linkSourcePath, MAX_PATH, tempFileName, - &tempFilePart)) { + if (!(*tclWinProcs->getFullPathNameProc)(linkSourcePath, MAX_PATH, + tempFileName, &tempFilePart)) { /* * Invalid file. */ @@ -325,7 +362,7 @@ WinReadLink( * Make sure source file does exist. */ - attr = GetFileAttributes(linkSourcePath); + attr = (*tclWinProcs->getFileAttributesProc)(linkSourcePath); if (attr == INVALID_FILE_ATTRIBUTES) { /* * The source doesn't exist. @@ -341,9 +378,9 @@ WinReadLink( Tcl_SetErrno(ENOTDIR); return NULL; + } else { + return WinReadLinkDirectory(linkSourcePath); } - - return WinReadLinkDirectory(linkSourcePath); } /* @@ -482,8 +519,9 @@ TclWinSymLinkDelete( memset(reparseBuffer, 0, sizeof(DUMMY_REPARSE_BUFFER)); reparseBuffer->ReparseTag = IO_REPARSE_TAG_MOUNT_POINT; - hFile = CreateFile(linkOrigPath, GENERIC_WRITE, 0, NULL, OPEN_EXISTING, - FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL); + hFile = (*tclWinProcs->createFileProc)(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, @@ -497,7 +535,7 @@ TclWinSymLinkDelete( } else { CloseHandle(hFile); if (!linkOnly) { - RemoveDirectory(linkOrigPath); + (*tclWinProcs->removeDirectoryProc)(linkOrigPath); } return 0; } @@ -537,7 +575,7 @@ WinReadLinkDirectory( Tcl_DString ds; const char *copy; - attr = GetFileAttributes(linkDirPath); + attr = (*tclWinProcs->getFileAttributesProc)(linkDirPath); if (!(attr & FILE_ATTRIBUTE_REPARSE_POINT)) { goto invalidError; } @@ -562,7 +600,6 @@ WinReadLinkDirectory( */ offset = 0; -#ifdef UNICODE if (reparseBuffer->MountPointReparseBuffer.PathBuffer[0] == L'\\') { /* * Check whether this is a mounted volume. @@ -624,9 +661,8 @@ WinReadLinkDirectory( offset = 4; } } -#endif /* UNICODE */ - Tcl_WinTCharToUtf((const TCHAR *) + Tcl_WinTCharToUtf((const char *) reparseBuffer->MountPointReparseBuffer.PathBuffer, (int) reparseBuffer->MountPointReparseBuffer .SubstituteNameLength, &ds); @@ -668,8 +704,9 @@ NativeReadReparse( HANDLE hFile; DWORD returnedLength; - hFile = CreateFile(linkDirPath, desiredAccess, 0, NULL, OPEN_EXISTING, - FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL); + hFile = (*tclWinProcs->createFileProc)(linkDirPath, desiredAccess, 0, + NULL, OPEN_EXISTING, + FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL); if (hFile == INVALID_HANDLE_VALUE) { /* @@ -727,7 +764,7 @@ NativeWriteReparse( * Create the directory - it must not already exist. */ - if (CreateDirectory(linkDirPath, NULL) == 0) { + if ((*tclWinProcs->createDirectoryProc)(linkDirPath, NULL) == 0) { /* * Error creating directory. */ @@ -735,9 +772,9 @@ NativeWriteReparse( TclWinConvertError(GetLastError()); return -1; } - hFile = CreateFile(linkDirPath, GENERIC_WRITE, 0, NULL, - OPEN_EXISTING, FILE_FLAG_OPEN_REPARSE_POINT - | FILE_FLAG_BACKUP_SEMANTICS, NULL); + hFile = (*tclWinProcs->createFileProc)(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. @@ -760,7 +797,7 @@ NativeWriteReparse( TclWinConvertError(GetLastError()); CloseHandle(hFile); - RemoveDirectory(linkDirPath); + (*tclWinProcs->removeDirectoryProc)(linkDirPath); return -1; } CloseHandle(hFile); @@ -773,65 +810,6 @@ 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 -- @@ -850,33 +828,28 @@ tclWinDebugPanic( void TclpFindExecutable( - const char *argv0) /* If NULL, install PanicMessageBox, otherwise - * ignore. */ + const char *argv0) /* The value of the application's argv[0] + * (native). */ { 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. Only if it is NULL, install a new panic handler. + * create this process. */ - if (argv0 == NULL) { - Tcl_SetPanicProc(tclWinDebugPanic); - } + if (GetModuleFileNameW(NULL, wName, MAX_PATH) == 0) { + GetModuleFileNameA(NULL, name, sizeof(name)); -#ifdef UNICODE - GetModuleFileNameW(NULL, wName, MAX_PATH); -#else - GetModuleFileNameA(NULL, name, sizeof(name)); + /* + * Convert to WCHAR to get out of ANSI codepage + */ - /* - * Convert to WCHAR to get out of ANSI codepage - */ + MultiByteToWideChar(CP_ACP, 0, name, -1, wName, MAX_PATH); + } - MultiByteToWideChar(CP_ACP, 0, name, -1, wName, MAX_PATH); -#endif - WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, sizeof(name), NULL, NULL); + WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, sizeof(name), NULL,NULL); TclWinNoBackslash(name); TclSetObjNameOfExecutable(Tcl_NewStringObj(name, -1), NULL); } @@ -922,7 +895,6 @@ TclpMatchInDirectory( if (pattern == NULL || (*pattern == '\0')) { Tcl_Obj *norm = Tcl_FSGetNormalizedPath(NULL, pathPtr); - if (norm != NULL) { /* * Match a single file directly. @@ -930,16 +902,23 @@ TclpMatchInDirectory( int len; DWORD attr; - WIN32_FILE_ATTRIBUTE_DATA data; const char *str = Tcl_GetStringFromObj(norm,&len); - native = Tcl_FSGetNativePath(pathPtr); + native = (const TCHAR *) Tcl_FSGetNativePath(pathPtr); - if (GetFileAttributesEx(native, - GetFileExInfoStandard, &data) != TRUE) { - return TCL_OK; + 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; } - attr = data.dwFileAttributes; if (NativeMatchType(WinIsDrive(str,len), attr, native, types)) { Tcl_ListObjAppendElement(interp, resultPtr, pathPtr); @@ -949,7 +928,7 @@ TclpMatchInDirectory( } else { DWORD attr; HANDLE handle; - WIN32_FIND_DATA data; + WIN32_FIND_DATAT data; const char *dirName; /* UTF-8 dir name, later with pattern * appended. */ int dirLength; @@ -978,10 +957,9 @@ TclpMatchInDirectory( if (native == NULL) { return TCL_OK; } - attr = GetFileAttributes(native); + attr = (*tclWinProcs->getFileAttributesProc)(native); - if ((attr == INVALID_FILE_ATTRIBUTES) - || ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0)) { + if ((attr == 0xffffffff) || ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0)) { return TCL_OK; } @@ -996,7 +974,7 @@ TclpMatchInDirectory( lastChar = dirName[dirLength -1]; if ((lastChar != '\\') && (lastChar != '/') && (lastChar != ':')) { - TclDStringAppendLiteral(&dsOrig, "/"); + Tcl_DStringAppend(&dsOrig, "/", 1); dirLength++; } dirName = Tcl_DStringValue(&dsOrig); @@ -1016,25 +994,25 @@ TclpMatchInDirectory( dirName = Tcl_DStringAppend(&dsOrig, pattern, -1); } else { - dirName = TclDStringAppendLiteral(&dsOrig, "*.*"); + dirName = Tcl_DStringAppend(&dsOrig, "*.*", 3); } native = Tcl_WinUtfToTChar(dirName, -1, &ds); - if ((types == NULL) || (types->type != TCL_GLOB_TYPE_DIR)) { - handle = FindFirstFile(native, &data); + if (tclWinProcs->findFirstFileExProc == NULL || (types == NULL) + || (types->type != TCL_GLOB_TYPE_DIR)) { + handle = (*tclWinProcs->findFirstFileProc)(native, &data); } else { /* * We can be more efficient, for pure directory requests. */ - handle = FindFirstFileEx(native, + handle = (*tclWinProcs->findFirstFileExProc)(native, FindExInfoStandard, &data, FindExSearchLimitToDirectories, NULL, 0); } if (handle == INVALID_HANDLE_VALUE) { DWORD err = GetLastError(); - Tcl_DStringFree(&ds); if (err == ERROR_FILE_NOT_FOUND) { /* @@ -1048,9 +1026,10 @@ TclpMatchInDirectory( TclWinConvertError(err); if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't read directory \"%s\": %s", - Tcl_DStringValue(&dsOrig), Tcl_PosixError(interp))); + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "couldn't read directory \"", + Tcl_DStringValue(&dsOrig), "\": ", + Tcl_PosixError(interp), NULL); } Tcl_DStringFree(&dsOrig); return TCL_ERROR; @@ -1090,8 +1069,14 @@ TclpMatchInDirectory( int checkDrive = 0, isDrive; DWORD attr; - native = data.cFileName; - attr = data.dwFileAttributes; + if (tclWinProcs->useWide) { + native = (const TCHAR *) data.w.cFileName; + attr = data.w.dwFileAttributes; + } else { + native = (const TCHAR *) data.a.cFileName; + attr = data.a.dwFileAttributes; + } + utfname = Tcl_WinTCharToUtf(native, -1, &ds); if (!matchSpecialDots) { @@ -1134,7 +1119,6 @@ TclpMatchInDirectory( if (checkDrive) { const char *fullname = Tcl_DStringAppend(&dsOrig, utfname, Tcl_DStringLength(&ds)); - isDrive = WinIsDrive(fullname, Tcl_DStringLength(&dsOrig)); Tcl_DStringSetLength(&dsOrig, dirLength); } else { @@ -1152,7 +1136,7 @@ TclpMatchInDirectory( */ Tcl_DStringFree(&ds); - } while (FindNextFile(handle, &data) == TRUE); + } while ((*tclWinProcs->findNextFileProc)(handle, &data) == TRUE); FindClose(handle); Tcl_DStringFree(&dsOrig); @@ -1325,80 +1309,81 @@ NativeMatchType( * If invisible, don't return the file. */ - return !(attr & FILE_ATTRIBUTE_HIDDEN && !isDrive); - } - - if (attr & FILE_ATTRIBUTE_HIDDEN && !isDrive) { - /* - * If invisible. - */ - - if ((types->perm == 0) || !(types->perm & TCL_GLOB_PERM_HIDDEN)) { + if (attr & FILE_ATTRIBUTE_HIDDEN && !isDrive) { return 0; } } else { - /* - * Visible. - */ + if (attr & FILE_ATTRIBUTE_HIDDEN && !isDrive) { + /* + * If invisible. + */ - if (types->perm & TCL_GLOB_PERM_HIDDEN) { - return 0; - } - } + if ((types->perm == 0) || !(types->perm & TCL_GLOB_PERM_HIDDEN)) { + return 0; + } + } else { + /* + * Visible. + */ - 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 & TCL_GLOB_PERM_HIDDEN) { + return 0; + } } - } - if ((types->type & TCL_GLOB_TYPE_DIR) - && (attr & FILE_ATTRIBUTE_DIRECTORY)) { - /* - * Quicker test for directory, which is a common case. - */ + 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; + return 1; - } else if (types->type != 0) { - unsigned short st_mode; - int isExec = NativeIsExec(nativeName); + } else if (types->type != 0) { + unsigned short st_mode; + int isExec = NativeIsExec(nativeName); - st_mode = NativeStatMode(attr, 0, isExec); + st_mode = NativeStatMode(attr, 0, isExec); - /* - * In order bcdpfls as in 'find -t' - */ + /* + * 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)) || + 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; @@ -1425,56 +1410,80 @@ NativeMatchType( *---------------------------------------------------------------------- */ -const char * +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. */ { - 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]; + char *result; + HINSTANCE netapiInst; + 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". - */ - GetWindowsDirectoryW(buf, MAX_PATH); - Tcl_UniCharToUtfDString(buf, 2, bufferPtr); - TclDStringAppendLiteral(bufferPtr, "/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); } - result = Tcl_DStringValue(bufferPtr); - NetApiBufferFree((void *) uiPtr); } - Tcl_DStringFree(&ds); - } - if (wDomain != NULL) { - NetApiBufferFree((void *) wDomain); + FreeLibrary(netapiInst); } if (result == NULL) { /* @@ -1530,9 +1539,9 @@ NativeAccess( { DWORD attr; - attr = GetFileAttributes(nativePath); + attr = (*tclWinProcs->getFileAttributesProc)(nativePath); - if (attr == INVALID_FILE_ATTRIBUTES) { + if (attr == 0xffffffff) { /* * File might not exist. */ @@ -1588,8 +1597,7 @@ NativeAccess( * what permissions the OS has set for a file. */ -#ifdef UNICODE - { + if (tclWinProcs->getFileSecurityProc != NULL) { SECURITY_DESCRIPTOR *sdPtr = NULL; unsigned long size; PSID pSid = 0; @@ -1604,11 +1612,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; - GetFileSecurity(nativePath, + (*tclWinProcs->getFileSecurityProc)(nativePath, OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION | LABEL_SECURITY_INFORMATION, 0, 0, &size); @@ -1642,7 +1650,7 @@ NativeAccess( * Call GetFileSecurity() for real. */ - if (!GetFileSecurity(nativePath, + if (!(*tclWinProcs->getFileSecurityProc)(nativePath, OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION | LABEL_SECURITY_INFORMATION, sdPtr, size, &size)) { @@ -1678,14 +1686,14 @@ NativeAccess( * thread token. */ - if (!ImpersonateSelf(SecurityImpersonation)) { + if (!(*tclWinProcs->impersonateSelfProc)(SecurityImpersonation)) { /* * Unable to perform security impersonation. */ goto accessError; } - if (!OpenThreadToken(GetCurrentThread(), + if (!(*tclWinProcs->openThreadTokenProc)(GetCurrentThread(), TOKEN_DUPLICATE | TOKEN_QUERY, FALSE, &hToken)) { /* * Unable to get current thread's token. @@ -1694,7 +1702,7 @@ NativeAccess( goto accessError; } - RevertToSelf(); + (*tclWinProcs->revertToSelfProc)(); /* * Setup desiredAccess according to the access priveleges we are @@ -1721,7 +1729,7 @@ NativeAccess( * Perform access check using the token. */ - if (!AccessCheck(sdPtr, hToken, desiredAccess, + if (!(*tclWinProcs->accessCheckProc)(sdPtr, hToken, desiredAccess, &genMap, &privSet, &privSetSize, &grantedAccess, &accessYesNo)) { /* @@ -1751,7 +1759,6 @@ NativeAccess( } } -#endif /* !UNICODE */ return 0; } @@ -1771,22 +1778,55 @@ NativeAccess( static int NativeIsExec( - const TCHAR *path) + const TCHAR *nativePath) { - int len = _tcslen(path); + if (tclWinProcs->useWide) { + const WCHAR *path = (const WCHAR *) nativePath; + int len = wcslen(path); - if (len < 5) { - return 0; - } + if (len < 5) { + return 0; + } - if (path[len-4] != '.') { - 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++; - if ((_tcsicmp(path+len-3, TEXT("exe")) == 0) - || (_tcsicmp(path+len-3, TEXT("com")) == 0) - || (_tcsicmp(path+len-3, TEXT("bat")) == 0)) { - return 1; + /* + * Note: in the old code, stat considered '.pif' files as + * executable, whereas access did not. + */ + + if ((strcasecmp(p, "exe") == 0) + || (strcasecmp(p, "com") == 0) + || (strcasecmp(p, "bat") == 0)) { + /* + * File that ends with .exe, .com, or .bat is executable. + */ + + return 1; + } + } } return 0; } @@ -1814,9 +1854,9 @@ TclpObjChdir( int result; const TCHAR *nativePath; - nativePath = Tcl_FSGetNativePath(pathPtr); + nativePath = (const TCHAR *) Tcl_FSGetNativePath(pathPtr); - result = SetCurrentDirectory(nativePath); + result = (*tclWinProcs->setCurrentDirectoryProc)(nativePath); if (result == 0) { TclWinConvertError(GetLastError()); @@ -1853,16 +1893,14 @@ TclpGetCwd( Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with * name of current directory. */ { - TCHAR buffer[MAX_PATH]; + WCHAR buffer[MAX_PATH]; char *p; - WCHAR *native; - if (GetCurrentDirectory(MAX_PATH, buffer) == 0) { + if ((*tclWinProcs->getCurrentDirectoryProc)(MAX_PATH, buffer) == 0) { TclWinConvertError(GetLastError()); if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "error getting working directory name: %s", - Tcl_PosixError(interp))); + Tcl_AppendResult(interp, "error getting working directory name: ", + Tcl_PosixError(interp), NULL); } return NULL; } @@ -1871,12 +1909,25 @@ TclpGetCwd( * Watch for the weird Windows c:\\UNC syntax. */ - native = (WCHAR *) buffer; - if ((native[0] != '\0') && (native[1] == ':') - && (native[2] == '\\') && (native[3] == '\\')) { - native += 2; + 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); } - Tcl_WinTCharToUtf((TCHAR *) native, -1, bufferPtr); /* * Convert to forward slashes for easier use in scripts. @@ -1903,7 +1954,8 @@ TclpObjStat( TclWinFlushDirtyChannels(); - return NativeStat(Tcl_FSGetNativePath(pathPtr), statPtr, 0); + return NativeStat((const TCHAR *) Tcl_FSGetNativePath(pathPtr), + statPtr, 0); } /* @@ -1949,7 +2001,7 @@ NativeStat( * simpler routines. */ - fileHandle = CreateFile(nativePath, GENERIC_READ, + fileHandle = (tclWinProcs->createFileProc)(nativePath, GENERIC_READ, FILE_SHARE_READ | FILE_SHARE_WRITE, NULL, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OPEN_REPARSE_POINT, NULL); @@ -1988,24 +2040,24 @@ NativeStat( */ inode = data.nFileIndexHigh | data.nFileIndexLow; - } else { + } else if (tclWinProcs->getFileAttributesExProc != NULL) { /* * Fall back on the less capable routines. This means no nlink or ino. */ WIN32_FILE_ATTRIBUTE_DATA data; - if (GetFileAttributesEx(nativePath, + if ((*tclWinProcs->getFileAttributesExProc)(nativePath, GetFileExInfoStandard, &data) != TRUE) { HANDLE hFind; - WIN32_FIND_DATA ffd; + WIN32_FIND_DATAT ffd; DWORD lasterror = GetLastError(); if (lasterror != ERROR_SHARING_VIOLATION) { TclWinConvertError(lasterror); return -1; } - hFind = FindFirstFile(nativePath, &ffd); + hFind = (*tclWinProcs->findFirstFileProc)(nativePath, &ffd); if (hFind == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); return -1; @@ -2021,6 +2073,46 @@ 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); @@ -2052,12 +2144,14 @@ NativeDev( { int dev; Tcl_DString ds; - TCHAR nativeFullPath[MAX_PATH]; + WCHAR nativeFullPath[MAX_PATH]; TCHAR *nativePart; const char *fullPath; - GetFullPathName(nativePath, MAX_PATH, nativeFullPath, &nativePart); - fullPath = Tcl_WinTCharToUtf(nativeFullPath, -1, &ds); + (*tclWinProcs->getFullPathNameProc)(nativePath, MAX_PATH, + nativeFullPath, &nativePart); + + fullPath = Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds); if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) { const char *p; @@ -2073,14 +2167,15 @@ NativeDev( * won't work. */ - fullPath = TclDStringAppendLiteral(&ds, "\\"); + fullPath = Tcl_DStringAppend(&ds, "\\", 1); p = fullPath + Tcl_DStringLength(&ds); } else { p++; } nativeVol = Tcl_WinUtfToTChar(fullPath, p - fullPath, &volString); dw = (DWORD) -1; - GetVolumeInformation(nativeVol, NULL, 0, &dw, NULL, NULL, NULL, 0); + (*tclWinProcs->getVolumeInformationProc)(nativeVol, NULL, 0, &dw, + NULL, NULL, NULL, 0); /* * GetFullPathName() turns special devices like "NUL" into "\\.\NUL", @@ -2192,9 +2287,8 @@ 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; } @@ -2224,20 +2318,34 @@ ClientData TclpGetNativeCwd( ClientData clientData) { - TCHAR buffer[MAX_PATH]; + WCHAR buffer[MAX_PATH]; - if (GetCurrentDirectory(MAX_PATH, buffer) == 0) { + if ((*tclWinProcs->getCurrentDirectoryProc)(MAX_PATH, buffer) == 0) { TclWinConvertError(GetLastError()); return NULL; } if (clientData != NULL) { - if (_tcscmp((const TCHAR*)clientData, buffer) == 0) { - return clientData; + 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; + } } } - return TclNativeDupInternalRep(buffer); + return TclNativeDupInternalRep((ClientData) buffer); } int @@ -2245,7 +2353,7 @@ TclpObjAccess( Tcl_Obj *pathPtr, int mode) { - return NativeAccess(Tcl_FSGetNativePath(pathPtr), mode); + return NativeAccess((const TCHAR *) Tcl_FSGetNativePath(pathPtr), mode); } int @@ -2261,7 +2369,8 @@ TclpObjLstat( TclWinFlushDirtyChannels(); - return NativeStat(Tcl_FSGetNativePath(pathPtr), statPtr, 1); + return NativeStat((const TCHAR *) Tcl_FSGetNativePath(pathPtr), + statPtr, 1); } #ifdef S_IFLNK @@ -2273,15 +2382,15 @@ TclpObjLink( { if (toPtr != NULL) { int res; - const TCHAR *LinkTarget; - const TCHAR *LinkSource = Tcl_FSGetNativePath(pathPtr); + TCHAR *LinkTarget; + TCHAR *LinkSource = (TCHAR *) Tcl_FSGetNativePath(pathPtr); Tcl_Obj *normalizedToPtr = Tcl_FSGetNormalizedPath(NULL, toPtr); if (normalizedToPtr == NULL) { return NULL; } - LinkTarget = Tcl_FSGetNativePath(normalizedToPtr); + LinkTarget = (TCHAR *) Tcl_FSGetNativePath(normalizedToPtr); if (LinkSource == NULL || LinkTarget == NULL) { return NULL; @@ -2293,7 +2402,7 @@ TclpObjLink( return NULL; } } else { - const TCHAR *LinkSource = Tcl_FSGetNativePath(pathPtr); + TCHAR *LinkSource = (TCHAR *) Tcl_FSGetNativePath(pathPtr); if (LinkSource == NULL) { return NULL; @@ -2301,7 +2410,7 @@ TclpObjLink( return WinReadLink(LinkSource); } } -#endif /* S_IFLNK */ +#endif /* *--------------------------------------------------------------------------- @@ -2327,7 +2436,7 @@ TclpFilesystemPathType( { #define VOL_BUF_SIZE 32 int found; - TCHAR volType[VOL_BUF_SIZE]; + WCHAR volType[VOL_BUF_SIZE]; char *firstSeparator; const char *path; Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr); @@ -2342,14 +2451,16 @@ TclpFilesystemPathType( firstSeparator = strchr(path, '/'); if (firstSeparator == NULL) { - found = GetVolumeInformation(Tcl_FSGetNativePath(pathPtr), - NULL, 0, NULL, NULL, NULL, volType, VOL_BUF_SIZE); + found = tclWinProcs->getVolumeInformationProc( + Tcl_FSGetNativePath(pathPtr), NULL, 0, NULL, NULL, NULL, + (WCHAR *) volType, VOL_BUF_SIZE); } else { Tcl_Obj *driveName = Tcl_NewStringObj(path, firstSeparator - path+1); Tcl_IncrRefCount(driveName); - found = GetVolumeInformation(Tcl_FSGetNativePath(driveName), - NULL, 0, NULL, NULL, NULL, volType, VOL_BUF_SIZE); + found = tclWinProcs->getVolumeInformationProc( + Tcl_FSGetNativePath(driveName), NULL, 0, NULL, NULL, NULL, + (WCHAR *) volType, VOL_BUF_SIZE); Tcl_DecrRefCount(driveName); } @@ -2357,9 +2468,13 @@ TclpFilesystemPathType( return NULL; } else { Tcl_DString ds; + Tcl_Obj *objPtr; - Tcl_WinTCharToUtf(volType, -1, &ds); - return TclDStringToObj(&ds); + Tcl_WinTCharToUtf((const char *) volType, -1, &ds); + objPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), + Tcl_DStringLength(&ds)); + Tcl_DStringFree(&ds); + return objPtr; } #undef VOL_BUF_SIZE } @@ -2409,8 +2524,6 @@ 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); @@ -2421,11 +2534,11 @@ TclpObjNormalizePath( * 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. - * - * FIXME: This code branch may be derelict as those are not supported - * platforms any more. */ + int isDrive = 1; + Tcl_DString ds; + currentPathEndPosition = path + nextCheckpoint; if (*currentPathEndPosition == '/') { currentPathEndPosition++; @@ -2511,7 +2624,7 @@ TclpObjNormalizePath( * path segment and continue */ - Tcl_DStringAppend(&dsNorm, (const char *) + Tcl_DStringAppend(&dsNorm, (TCHAR *) (nativePath + Tcl_DStringLength(&ds)-dotLen), dotLen); } else { @@ -2519,7 +2632,7 @@ TclpObjNormalizePath( * Normal path. */ - WIN32_FIND_DATAA fData; + WIN32_FIND_DATA fData; HANDLE handle; handle = FindFirstFileA(nativePath, &fData); @@ -2539,7 +2652,7 @@ TclpObjNormalizePath( * string. */ - TclDStringAppendLiteral(&dsNorm, "/"); + Tcl_DStringAppend(&dsNorm,"/", 1); } else { char *nativeName; @@ -2549,8 +2662,8 @@ TclpObjNormalizePath( nativeName = fData.cAlternateFileName; } FindClose(handle); - TclDStringAppendLiteral(&dsNorm, "/"); - Tcl_DStringAppend(&dsNorm, nativeName, -1); + Tcl_DStringAppend(&dsNorm,"/", 1); + Tcl_DStringAppend(&dsNorm,nativeName,-1); } } } @@ -2574,6 +2687,9 @@ TclpObjNormalizePath( * 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++; @@ -2587,10 +2703,10 @@ TclpObjNormalizePath( */ WIN32_FILE_ATTRIBUTE_DATA data; - const TCHAR *nativePath = Tcl_WinUtfToTChar(path, + const char *nativePath = Tcl_WinUtfToTChar(path, currentPathEndPosition - path, &ds); - if (GetFileAttributesEx(nativePath, + if ((*tclWinProcs->getFileAttributesExProc)(nativePath, GetFileExInfoStandard, &data) != TRUE) { /* * File doesn't exist. @@ -2614,8 +2730,7 @@ TclpObjNormalizePath( ((WCHAR *) nativePath)[i] = wc; } } - Tcl_DStringAppend(&dsNorm, - (const char *)nativePath, + Tcl_DStringAppend(&dsNorm, nativePath, (int)(sizeof(WCHAR) * len)); lastValidPathEnd = currentPathEndPosition; } else if (nextCheckpoint == 0) { @@ -2654,7 +2769,7 @@ TclpObjNormalizePath( * not be normalized, otherwise we could use: * * Tcl_GetStringFromObj(to, &pathLen); - * nextCheckpoint = pathLen; + * nextCheckpoint = pathLen * * So, instead we have to start from the beginning. */ @@ -2684,6 +2799,7 @@ TclpObjNormalizePath( isDrive = 1; Tcl_DStringFree(&dsNorm); + Tcl_DStringInit(&dsNorm); Tcl_DStringFree(&ds); continue; } @@ -2698,12 +2814,11 @@ TclpObjNormalizePath( if (isDrive) { WCHAR drive = ((WCHAR *) nativePath)[0]; - if (drive >= L'a') { drive -= (L'a' - L'A'); ((WCHAR *) nativePath)[0] = drive; } - Tcl_DStringAppend(&dsNorm, (const char *)nativePath, + Tcl_DStringAppend(&dsNorm, nativePath, Tcl_DStringLength(&ds)); } else { char *checkDots = NULL; @@ -2728,10 +2843,9 @@ TclpObjNormalizePath( * path segment and continue. */ - Tcl_DStringAppend(&dsNorm, ((const char *)nativePath) - + Tcl_DStringLength(&ds) - - (dotLen * sizeof(TCHAR)), - (int)(dotLen * sizeof(TCHAR))); + Tcl_DStringAppend(&dsNorm, (TCHAR *) + ((WCHAR*)(nativePath + Tcl_DStringLength(&ds)) + - dotLen), (int)(dotLen * sizeof(WCHAR))); } else { /* * Normal path. @@ -2760,13 +2874,12 @@ TclpObjNormalizePath( FindClose(handle); Tcl_DStringAppend(&dsNorm, (const char *) L"/", sizeof(WCHAR)); - Tcl_DStringAppend(&dsNorm, - (const char *) nativeName, + Tcl_DStringAppend(&dsNorm, (TCHAR *) nativeName, (int) (wcslen(nativeName)*sizeof(WCHAR))); } } } -#endif /* !TclNORM_LONG_PATH */ +#endif Tcl_DStringFree(&ds); lastValidPathEnd = currentPathEndPosition; if (cur == 0) { @@ -2790,10 +2903,10 @@ TclpObjNormalizePath( if (1) { WCHAR wpath[MAX_PATH]; - const TCHAR *nativePath = + const char *nativePath = Tcl_WinUtfToTChar(path, lastValidPathEnd - path, &ds); - DWORD wpathlen = GetLongPathNameProc(nativePath, - (TCHAR *) wpath, MAX_PATH); + DWORD wpathlen = (*tclWinProcs->getLongPathNameProc)( + nativePath, (TCHAR *) wpath, MAX_PATH); /* * We have to make the drive letter uppercase. @@ -2802,11 +2915,10 @@ TclpObjNormalizePath( if (wpath[0] >= L'a') { wpath[0] -= (L'a' - L'A'); } - Tcl_DStringAppend(&dsNorm, (const char *) wpath, - wpathlen * sizeof(WCHAR)); + Tcl_DStringAppend(&dsNorm, (TCHAR*)wpath, wpathlen*sizeof(WCHAR)); Tcl_DStringFree(&ds); } -#endif /* TclNORM_LONG_PATH */ +#endif } /* @@ -2821,9 +2933,11 @@ TclpObjNormalizePath( * native encoding, so we have to convert it to Utf. */ - Tcl_WinTCharToUtf((const TCHAR *) Tcl_DStringValue(&dsNorm), - Tcl_DStringLength(&dsNorm), &ds); - nextCheckpoint = Tcl_DStringLength(&ds); + Tcl_DString dsTemp; + + Tcl_WinTCharToUtf(Tcl_DStringValue(&dsNorm), + Tcl_DStringLength(&dsNorm), &dsTemp); + nextCheckpoint = Tcl_DStringLength(&dsTemp); if (*lastValidPathEnd != 0) { /* * Not the end of the string. @@ -2833,7 +2947,7 @@ TclpObjNormalizePath( char *path; Tcl_Obj *tmpPathPtr; - tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), + tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsTemp), nextCheckpoint); Tcl_AppendToObj(tmpPathPtr, lastValidPathEnd, -1); path = Tcl_GetStringFromObj(tmpPathPtr, &len); @@ -2844,9 +2958,10 @@ TclpObjNormalizePath( * End of string was reached above. */ - Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&ds), nextCheckpoint); + Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&dsTemp), + nextCheckpoint); } - Tcl_DStringFree(&ds); + Tcl_DStringFree(&dsTemp); } Tcl_DStringFree(&dsNorm); @@ -2858,7 +2973,6 @@ TclpObjNormalizePath( if (temp != NULL) { Tcl_DecrRefCount(temp); } - return nextCheckpoint; } @@ -2998,7 +3112,7 @@ TclpNativeToNormalized( int len; char *copy, *p; - Tcl_WinTCharToUtf((const TCHAR *) clientData, -1, &ds); + Tcl_WinTCharToUtf((const char *) clientData, -1, &ds); copy = Tcl_DStringValue(&ds); len = Tcl_DStringLength(&ds); @@ -3093,13 +3207,17 @@ TclNativeCreateNativeRep( } } Tcl_WinUtfToTChar(str, len, &ds); - len = Tcl_DStringLength(&ds) + sizeof(WCHAR); + if (tclWinProcs->useWide) { + len = Tcl_DStringLength(&ds) + sizeof(WCHAR); + } else { + len = Tcl_DStringLength(&ds) + sizeof(char); + } Tcl_DecrRefCount(validPathPtr); - nativePathPtr = ckalloc(len); + nativePathPtr = ckalloc((unsigned) len); memcpy(nativePathPtr, Tcl_DStringValue(&ds), (size_t) len); Tcl_DStringFree(&ds); - return nativePathPtr; + return (ClientData) nativePathPtr; } /* @@ -3130,11 +3248,23 @@ TclNativeDupInternalRep( return NULL; } - len = sizeof(TCHAR) * (_tcslen((const TCHAR *) clientData) + 1); + 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); + } - copy = ckalloc(len); + copy = (char *) ckalloc(len); memcpy(copy, clientData, len); - return copy; + return (ClientData) copy; } /* @@ -3169,9 +3299,9 @@ TclpUtime( FromCTime(tval->actime, &lastAccessTime); FromCTime(tval->modtime, &lastModTime); - native = Tcl_FSGetNativePath(pathPtr); + native = (const TCHAR *) Tcl_FSGetNativePath(pathPtr); - attr = GetFileAttributes(native); + attr = (*tclWinProcs->getFileAttributesProc)(native); if (attr != INVALID_FILE_ATTRIBUTES && attr & FILE_ATTRIBUTE_DIRECTORY) { flags = FILE_FLAG_BACKUP_SEMANTICS; @@ -3182,8 +3312,8 @@ TclpUtime( * savings complications that utime gets wrong. */ - fileHandle = CreateFile(native, FILE_WRITE_ATTRIBUTES, 0, NULL, - OPEN_EXISTING, flags, NULL); + fileHandle = (tclWinProcs->createFileProc)(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 f552e2c..5baf020 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -83,12 +83,12 @@ typedef struct { #define NUMPLATFORMS 4 -static const char *const platforms[NUMPLATFORMS] = { +static char* platforms[NUMPLATFORMS] = { "Win32s", "Windows 95", "Windows NT", "Windows CE" }; #define NUMPROCESSORS 11 -static const char *const processors[NUMPROCESSORS] = { +static char* 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]; - const char *bytes; + char *bytes; pathPtr = Tcl_NewObj(); @@ -219,7 +219,7 @@ TclpInitLibraryPath( *encodingPtr = NULL; bytes = Tcl_GetStringFromObj(pathPtr, lengthPtr); - *valuePtr = ckalloc((*lengthPtr) + 1); + *valuePtr = ckalloc((unsigned int)(*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,6 +299,8 @@ 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 @@ -308,13 +310,14 @@ AppendEnvironment( pathv[pathc - 1] = shortlib; Tcl_DStringInit(&ds); - (void) Tcl_JoinPath(pathc, pathv, &ds); - objPtr = TclDStringToObj(&ds); + str = Tcl_JoinPath(pathc, pathv, &ds); + objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&ds)); + Tcl_DStringFree(&ds); } else { objPtr = Tcl_NewStringObj(buf, -1); } Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); - ckfree(pathv); + ckfree((char *) pathv); } } @@ -414,7 +417,7 @@ InitializeSourceLibraryDir( TclWinNoBackslash(name); sprintf(end + 1, "../library"); *lengthPtr = strlen(name); - *valuePtr = ckalloc(*lengthPtr + 1); + *valuePtr = ckalloc((unsigned int) *lengthPtr + 1); *encodingPtr = NULL; memcpy(*valuePtr, name, (size_t) *lengthPtr + 1); } @@ -437,7 +440,7 @@ InitializeSourceLibraryDir( static int ToUtf( - const WCHAR *wSrc, + CONST WCHAR *wSrc, char *dst) { char *start; @@ -454,6 +457,31 @@ 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 @@ -489,13 +517,15 @@ TclpSetInitialEncodings(void) void TclpSetInterfaces(void) { - int useWide; + int platformId, useWide; - useWide = (TclWinGetPlatformId() != VER_PLATFORM_WIN32_WINDOWS); + platformId = TclWinGetPlatformId(); + useWide = ((platformId == VER_PLATFORM_WIN32_NT) + || (platformId == VER_PLATFORM_WIN32_CE)); TclWinSetInterfaces(useWide); } -const char * +CONST char * Tcl_GetEncodingNameFromEnvironment( Tcl_DString *bufPtr) { @@ -527,7 +557,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; @@ -535,7 +565,7 @@ TclpSetVariables( } sys; OSVERSIONINFOA osInfo; Tcl_DString ds; - TCHAR szUserName[UNLEN+1]; + WCHAR szUserName[UNLEN+1]; DWORD cchUserNameLen = UNLEN; Tcl_SetVar2Ex(interp, "tclDefaultLibrary", NULL, @@ -564,7 +594,7 @@ TclpSetVariables( TCL_GLOBAL_ONLY); } -#ifdef _DEBUG +#ifndef NDEBUG /* * The existence of the "debug" element of the tcl_platform array * indicates that this particular Tcl shell has been compiled with debug @@ -609,21 +639,15 @@ TclpSetVariables( Tcl_DStringInit(&ds); if (TclGetEnv("USERNAME", &ds) == NULL) { - if (GetUserName(szUserName, &cchUserNameLen) != 0) { + if (tclWinProcs->getUserName((LPTSTR)szUserName, &cchUserNameLen) != 0) { int cbUserNameLen = cchUserNameLen - 1; - cbUserNameLen *= sizeof(TCHAR); - Tcl_WinTCharToUtf(szUserName, cbUserNameLen, &ds); + if (tclWinProcs->useWide) cbUserNameLen *= sizeof(WCHAR); + Tcl_WinTCharToUtf((LPTSTR)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); } /* @@ -648,7 +672,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 @@ -656,7 +680,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; @@ -665,7 +689,7 @@ TclpFindVariable( */ length = strlen(name); - nameUpper = ckalloc(length + 1); + nameUpper = (char *) ckalloc((unsigned) length+1); memcpy(nameUpper, name, (size_t) length+1); Tcl_UtfToUpper(nameUpper); diff --git a/win/tclWinInt.h b/win/tclWinInt.h index 22ad8e9..2f6659c 100644 --- a/win/tclWinInt.h +++ b/win/tclWinInt.h @@ -15,6 +15,14 @@ #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. @@ -33,11 +41,117 @@ # define TCL_I_MODIFIER "" #endif -#ifdef _WIN64 -# define TCL_I_MODIFIER "I" -#else -# define TCL_I_MODIFIER "" -#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 @@ -45,7 +159,7 @@ */ MODULE_SCOPE char TclWinDriveLetterForVolMountPoint( - const TCHAR *mountPoint); + CONST WCHAR *mountPoint); MODULE_SCOPE void TclWinEncodingsCleanup(); MODULE_SCOPE void TclWinInit(HINSTANCE hInst); MODULE_SCOPE TclFile TclWinMakeFile(HANDLE handle); @@ -55,11 +169,12 @@ MODULE_SCOPE Tcl_Channel TclWinOpenFileChannel(HANDLE handle, char *channelName, int permissions, int appendMode); MODULE_SCOPE Tcl_Channel TclWinOpenSerialChannel(HANDLE handle, char *channelName, int permissions); -MODULE_SCOPE HANDLE TclWinSerialReopen(HANDLE handle, const TCHAR *name, +MODULE_SCOPE void TclWinResetInterfaceEncodings(); +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 3e11224..c4d08e8 100644 --- a/win/tclWinLoad.c +++ b/win/tclWinLoad.c @@ -13,23 +13,6 @@ #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); /* *---------------------------------------------------------------------- @@ -57,15 +40,13 @@ 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 hInstance; - const TCHAR *nativeName; - Tcl_LoadHandle handlePtr; + HINSTANCE handle; + CONST TCHAR *nativeName; /* * First try the full path the user gave us. This is particularly @@ -74,8 +55,9 @@ TclpDlopen( */ nativeName = Tcl_FSGetNativePath(pathPtr); - hInstance = LoadLibraryEx(nativeName,NULL,LOAD_WITH_ALTERED_SEARCH_PATH); - if (hInstance == NULL) { + handle = (*tclWinProcs->loadLibraryExProc)(nativeName, NULL, + LOAD_WITH_ALTERED_SEARCH_PATH); + if (handle == 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 @@ -83,17 +65,38 @@ TclpDlopen( */ Tcl_DString ds; + char *fileName = Tcl_GetString(pathPtr); - nativeName = Tcl_WinUtfToTChar(Tcl_GetString(pathPtr), -1, &ds); - hInstance = LoadLibraryEx(nativeName, NULL, + nativeName = Tcl_WinUtfToTChar(fileName, -1, &ds); + handle = (*tclWinProcs->loadLibraryExProc)(nativeName, NULL, LOAD_WITH_ALTERED_SEARCH_PATH); Tcl_DStringFree(&ds); } - if (hInstance == NULL) { + *loadHandle = (Tcl_LoadHandle) handle; + + if (handle == NULL) { DWORD lastError = GetLastError(); - Tcl_Obj *errMsg = Tcl_ObjPrintf("couldn't load library \"%s\": ", - Tcl_GetString(pathPtr)); + +#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); /* * Check for possible DLL errors. This doesn't work quite right, @@ -104,55 +107,38 @@ 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_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); + Tcl_AppendResult(interp, "this library or a dependent library" + " could not be found in library path", NULL); break; case ERROR_PROC_NOT_FOUND: - Tcl_SetErrorCode(interp, "WIN_LOAD", "PROC_NOT_FOUND", NULL); - Tcl_AppendToObj(errMsg, "A function specified in the import" - " table could not be resolved by the system. Windows" - " is not telling which one, I'm sorry.", -1); + Tcl_AppendResult(interp, "A function specified in the import" + " table could not be resolved by the system. Windows" + " is not telling which one, I'm sorry.", NULL); break; case ERROR_INVALID_DLL: - Tcl_SetErrorCode(interp, "WIN_LOAD", "INVALID_DLL", NULL); - Tcl_AppendToObj(errMsg, "this library or a dependent library" - " is damaged", -1); + Tcl_AppendResult(interp, "this library or a dependent library" + " is damaged", NULL); break; case ERROR_DLL_INIT_FAILED: - Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_INIT_FAILED", NULL); - Tcl_AppendToObj(errMsg, "the library initialization" - " routine failed", -1); + Tcl_AppendResult(interp, "the library initialization" + " routine failed", NULL); break; default: TclWinConvertError(lastError); - Tcl_AppendToObj(errMsg, Tcl_PosixError(interp), -1); + Tcl_AppendResult(interp, Tcl_PosixError(interp), NULL); } - 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; } /* *---------------------------------------------------------------------- * - * FindSymbol -- + * TclpFindSymbol -- * * Looks up a symbol, by name, through a handle associated with a * previously loaded piece of code (shared library). @@ -165,43 +151,37 @@ TclpDlopen( *---------------------------------------------------------------------- */ -static void * -FindSymbol( +Tcl_PackageInitProc * +TclpFindSymbol( 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 = (void *) GetProcAddress(hInstance, symbol); + proc = (Tcl_PackageInitProc *) GetProcAddress(handle, symbol); if (proc == NULL) { Tcl_DString ds; - const char *sym2; Tcl_DStringInit(&ds); - TclDStringAppendLiteral(&ds, "_"); - sym2 = Tcl_DStringAppend(&ds, symbol, -1); - proc = (Tcl_PackageInitProc *) GetProcAddress(hInstance, sym2); + Tcl_DStringAppend(&ds, "_", 1); + symbol = Tcl_DStringAppend(&ds, symbol, -1); + proc = (Tcl_PackageInitProc *) GetProcAddress(handle, symbol); 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; } /* *---------------------------------------------------------------------- * - * UnloadFile -- + * TclpUnloadFile -- * * Unloads a dynamically loaded binary code file from memory. Code * pointers in the formerly loaded file are no longer valid after calling @@ -216,16 +196,16 @@ FindSymbol( *---------------------------------------------------------------------- */ -static void -UnloadFile( +void +TclpUnloadFile( Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to * TclpDlopen(). The loadHandle is a token * that represents the loaded file. */ { - HINSTANCE hInstance = (HINSTANCE) loadHandle->clientData; + HINSTANCE handle; - FreeLibrary(hInstance); - ckfree(loadHandle); + handle = (HINSTANCE) loadHandle; + FreeLibrary(handle); } /* @@ -250,7 +230,7 @@ UnloadFile( 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. */ @@ -259,139 +239,6 @@ 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 4543b02..1cd5823 100644 --- a/win/tclWinNotify.c +++ b/win/tclWinNotify.c @@ -42,6 +42,9 @@ 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. @@ -50,7 +53,6 @@ static Tcl_ThreadDataKey dataKey; */ static int notifierCount = 0; -static const TCHAR classname[] = TEXT("TclNotifier"); TCL_DECLARE_MUTEX(notifierMutex) /* @@ -79,49 +81,45 @@ static LRESULT CALLBACK NotifierProc(HWND hwnd, UINT message, ClientData Tcl_InitNotifier(void) { - if (tclNotifierHooks.initNotifierProc) { - return tclNotifierHooks.initNotifierProc(); - } else { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - WNDCLASS class; + 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 = classname; - class.lpfnWndProc = NotifierProc; - class.hIcon = NULL; - class.hCursor = NULL; - - if (!RegisterClass(&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 = "TclNotifier"; + class.lpfnWndProc = NotifierProc; + class.hIcon = NULL; + class.hCursor = NULL; + + if (!RegisterClassA(&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 tsdPtr; - } + return (ClientData) tsdPtr; } /* @@ -145,51 +143,46 @@ void Tcl_FinalizeNotifier( ClientData clientData) /* Pointer to notifier data. */ { - if (tclNotifierHooks.finalizeNotifierProc) { - tclNotifierHooks.finalizeNotifierProc(clientData); - return; - } else { - ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; + 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) { - UnregisterClass(classname, TclWinGetTclInstance()); - } - Tcl_MutexUnlock(¬ifierMutex); + Tcl_MutexLock(¬ifierMutex); + notifierCount--; + if (notifierCount == 0) { + UnregisterClassA("TclNotifier", TclWinGetTclInstance()); } + Tcl_MutexUnlock(¬ifierMutex); } /* @@ -218,32 +211,27 @@ void Tcl_AlertNotifier( ClientData clientData) /* Pointer to thread data. */ { - if (tclNotifierHooks.alertNotifierProc) { - tclNotifierHooks.alertNotifierProc(clientData); - return; - } else { - ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; + 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 (tsdPtr->hwnd) { /* - * 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. + * We do need to lock around access to the pending flag. */ - 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); + EnterCriticalSection(&tsdPtr->crit); + if (!tsdPtr->pending) { + PostMessage(tsdPtr->hwnd, WM_WAKEUP, 0, 0); } + tsdPtr->pending = 1; + LeaveCriticalSection(&tsdPtr->crit); + } else { + SetEvent(tsdPtr->event); } } @@ -267,48 +255,53 @@ Tcl_AlertNotifier( void Tcl_SetTimer( - const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ + Tcl_Time *timePtr) /* Maximum block time, or NULL. */ { - if (tclNotifierHooks.setTimerProc) { - tclNotifierHooks.setTimerProc(timePtr); + 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; - } else { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - UINT timeout; + } - /* - * 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. - */ + /* + * 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) { - return; - } + 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. - */ + 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); + 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); + } } /* @@ -333,36 +326,29 @@ Tcl_ServiceModeHook( int mode) /* Either TCL_SERVICE_ALL, or * TCL_SERVICE_NONE. */ { - if (tclNotifierHooks.serviceModeHookProc) { - tclNotifierHooks.serviceModeHookProc(mode); - return; - } else { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + 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 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 = CreateWindow(classname, classname, - WS_TILED, 0, 0, 0, 0, NULL, NULL, TclWinGetTclInstance(), - NULL); + if (mode == TCL_SERVICE_ALL && !tsdPtr->hwnd) { + tsdPtr->hwnd = CreateWindowA("TclNotifier", "TclNotifier", 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. - */ + /* + * 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); - } + Tcl_AlertNotifier((ClientData)tsdPtr); } } @@ -430,102 +416,107 @@ NotifierProc( int Tcl_WaitForEvent( - const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ + Tcl_Time *timePtr) /* Maximum block time, or NULL. */ { - if (tclNotifierHooks.waitForEventProc) { - return tclNotifierHooks.waitForEventProc(timePtr); - } else { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - MSG msg; - DWORD timeout, result; - int status; + 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 (timePtr) { /* - * Compute the timeout in milliseconds. + * TIP #233 (Virtualized Time). Convert virtual domain delay to + * real-time. */ - if (timePtr) { - /* - * TIP #233 (Virtualized Time). Convert virtual domain delay to - * real-time. - */ + Tcl_Time myTime; - Tcl_Time myTime; + myTime.sec = timePtr->sec; + myTime.usec = timePtr->usec; - myTime.sec = timePtr->sec; - myTime.usec = timePtr->usec; + if (myTime.sec != 0 || myTime.usec != 0) { + (*tclScaleTimeProcPtr) (&myTime, tclTimeClientData); + } - if (myTime.sec != 0 || myTime.usec != 0) { - tclScaleTimeProcPtr(&myTime, tclTimeClientData); - } + timeout = myTime.sec * 1000 + myTime.usec / 1000; + } else { + timeout = INFINITE; + } - timeout = myTime.sec * 1000 + myTime.usec / 1000; - } else { - timeout = INFINITE; - } + /* + * Check to see if there are any messages in the queue before waiting + * because MsgWaitForMultipleObjects will not wake up if there are events + * currently sitting in the queue. + */ + if (!PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE)) { /* - * 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. + * Wait for something to happen (a signal from another thread, a + * message, or timeout) or loop servicing asynchronous procedure calls + * queued to this thread. */ - 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. - */ - - 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; - } + 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; } + } + + /* + * Check to see if there are any messages to process. + */ + if (PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE)) { /* - * Check to see if there are any messages to process. + * Retrieve and dispatch the first message. */ - if (PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE)) { + 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) { /* - * Retrieve and dispatch the first message. + * We got an error from the system. I have no idea why this would + * happen, so we'll just unwind. */ - 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; - } + status = -1; } else { - status = 0; + TranslateMessage(&msg); + DispatchMessage(&msg); + status = 1; } - - end: - ResetEvent(tsdPtr->event); - return status; + } else { + status = 0; } + + end: + ResetEvent(tsdPtr->event); + return status; } /* @@ -579,11 +570,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 (;;) { - SleepEx(sleepTime, TRUE); + Sleep(sleepTime); Tcl_GetTime(&now); if (now.sec > desired.sec) { break; @@ -594,7 +585,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 d418a3e..ee088a5 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(TCHAR name[MAX_PATH]); +static int TempFileName(WCHAR name[MAX_PATH]); static int WaitForRead(PipeInfo *infoPtr, int blocking); static void PipeThreadActionProc(ClientData instanceData, int action); @@ -202,7 +202,7 @@ static void PipeThreadActionProc(ClientData instanceData, * I/O. */ -static const Tcl_ChannelType pipeChannelType = { +static Tcl_ChannelType pipeChannelType = { "pipe", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ TCL_CLOSE2PROC, /* Close proc. */ @@ -219,7 +219,7 @@ static const 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 = ckalloc(sizeof(PipeEvent)); + evPtr = (PipeEvent *) 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 = ckalloc(sizeof(WinFile)); + filePtr = (WinFile *) ckalloc(sizeof(WinFile)); filePtr->type = WIN_FILE; filePtr->handle = handle; @@ -464,18 +464,27 @@ TclWinMakeFile( static int TempFileName( - TCHAR name[MAX_PATH]) /* Buffer in which name for temporary file + WCHAR name[MAX_PATH]) /* Buffer in which name for temporary file * gets stored. */ { - const TCHAR *prefix = TEXT("TCL"); - if (GetTempPath(MAX_PATH, name) != 0) { - if (GetTempFileName(name, prefix, 0, name) != 0) { + 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) { return 1; } } - name[0] = '.'; - name[1] = '\0'; - return GetTempFileName(name, prefix, 0, name); + 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); } /* @@ -587,7 +596,7 @@ TclpOpenFile( flags = 0; if (!(mode & O_CREAT)) { - flags = GetFileAttributes(nativePath); + flags = (*tclWinProcs->getFileAttributesProc)(nativePath); if (flags == 0xFFFFFFFF) { flags = 0; } @@ -603,8 +612,8 @@ TclpOpenFile( * Now we get to create the file. */ - handle = CreateFile(nativePath, accessMode, shareMode, - NULL, createMode, flags, NULL); + handle = (*tclWinProcs->createFileProc)(nativePath, accessMode, + shareMode, NULL, createMode, flags, NULL); Tcl_DStringFree(&ds); if (handle == INVALID_HANDLE_VALUE) { @@ -651,7 +660,7 @@ TclFile TclpCreateTempFile( const char *contents) /* String to write into temp file, or NULL. */ { - TCHAR name[MAX_PATH]; + WCHAR name[MAX_PATH]; const char *native; Tcl_DString dstring; HANDLE handle; @@ -660,7 +669,7 @@ TclpCreateTempFile( return NULL; } - handle = CreateFile(name, + handle = (*tclWinProcs->createFileProc)((TCHAR *) name, GENERIC_READ | GENERIC_WRITE, 0, NULL, CREATE_ALWAYS, FILE_ATTRIBUTE_TEMPORARY|FILE_FLAG_DELETE_ON_CLOSE, NULL); if (handle == INVALID_HANDLE_VALUE) { @@ -722,7 +731,7 @@ TclpCreateTempFile( TclWinConvertError(GetLastError()); CloseHandle(handle); - DeleteFile(name); + (*tclWinProcs->deleteFileProc)((TCHAR *) name); return NULL; } @@ -745,13 +754,13 @@ TclpCreateTempFile( Tcl_Obj * TclpTempFileName(void) { - TCHAR fileName[MAX_PATH]; + WCHAR fileName[MAX_PATH]; if (TempFileName(fileName) == 0) { return NULL; } - return TclpNativeToNormalized(fileName); + return TclpNativeToNormalized((ClientData) fileName); } /* @@ -827,7 +836,7 @@ TclpCloseFile( if (filePtr->handle != NULL && CloseHandle(filePtr->handle) == FALSE) { TclWinConvertError(GetLastError()); - ckfree(filePtr); + ckfree((char *) filePtr); return -1; } } @@ -837,7 +846,7 @@ TclpCloseFile( Tcl_Panic("TclpCloseFile: unexpected file type"); } - ckfree(filePtr); + ckfree((char *) filePtr); return 0; } @@ -938,7 +947,7 @@ TclpCreateProcess( { int result, applType, createFlags; Tcl_DString cmdLine; /* Complete command line (TCHAR). */ - STARTUPINFO startInfo; + STARTUPINFOA startInfo; PROCESS_INFORMATION procInfo; SECURITY_ATTRIBUTES secAtts; HANDLE hProcess, h, inputHandle, outputHandle, errorHandle; @@ -1028,9 +1037,8 @@ TclpCreateProcess( } if (startInfo.hStdInput == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't duplicate input handle: %s", - Tcl_PosixError(interp))); + Tcl_AppendResult(interp, "couldn't duplicate input handle: ", + Tcl_PosixError(interp), (char *) NULL); goto end; } @@ -1064,9 +1072,8 @@ TclpCreateProcess( } if (startInfo.hStdOutput == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't duplicate output handle: %s", - Tcl_PosixError(interp))); + Tcl_AppendResult(interp, "couldn't duplicate output handle: ", + Tcl_PosixError(interp), (char *) NULL); goto end; } @@ -1084,9 +1091,8 @@ TclpCreateProcess( } if (startInfo.hStdError == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't duplicate error handle: %s", - Tcl_PosixError(interp))); + Tcl_AppendResult(interp, "couldn't duplicate error handle: ", + Tcl_PosixError(interp), (char *) NULL); goto end; } @@ -1118,7 +1124,7 @@ TclpCreateProcess( startInfo.wShowWindow = SW_HIDE; startInfo.dwFlags |= STARTF_USESHOWWINDOW; createFlags = CREATE_NEW_CONSOLE; - TclDStringAppendLiteral(&cmdLine, "cmd.exe /c"); + Tcl_DStringAppend(&cmdLine, "cmd.exe /c", -1); } else { createFlags = DETACHED_PROCESS; } @@ -1130,12 +1136,82 @@ TclpCreateProcess( } if (applType == APPL_DOS) { - 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; + /* + * 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); } } @@ -1159,12 +1235,12 @@ TclpCreateProcess( BuildCommandLine(execPath, argc, argv, &cmdLine); - if (CreateProcess(NULL, (TCHAR *) Tcl_DStringValue(&cmdLine), - NULL, NULL, TRUE, (DWORD) createFlags, NULL, NULL, &startInfo, - &procInfo) == 0) { + if ((*tclWinProcs->createProcessProc)(NULL, + (TCHAR *) Tcl_DStringValue(&cmdLine), NULL, NULL, TRUE, + (DWORD) createFlags, NULL, NULL, &startInfo, &procInfo) == 0) { TclWinConvertError(GetLastError()); - Tcl_SetObjResult(interp, Tcl_ObjPrintf("couldn't execute \"%s\": %s", - argv[0], Tcl_PosixError(interp))); + Tcl_AppendResult(interp, "couldn't execute \"", argv[0], + "\": ", Tcl_PosixError(interp), (char *) NULL); goto end; } @@ -1292,7 +1368,7 @@ ApplicationType( IMAGE_DOS_HEADER header; Tcl_DString nameBuf, ds; const TCHAR *nativeName; - TCHAR nativeFullPath[MAX_PATH]; + WCHAR nativeFullPath[MAX_PATH]; static const char extensions[][5] = {"", ".com", ".exe", ".bat"}; /* @@ -1318,8 +1394,8 @@ ApplicationType( Tcl_DStringAppend(&nameBuf, extensions[i], -1); nativeName = Tcl_WinUtfToTChar(Tcl_DStringValue(&nameBuf), Tcl_DStringLength(&nameBuf), &ds); - found = SearchPath(NULL, nativeName, NULL, MAX_PATH, - nativeFullPath, &rest); + found = (*tclWinProcs->searchPathProc)(NULL, nativeName, NULL, + MAX_PATH, nativeFullPath, &rest); Tcl_DStringFree(&ds); if (found == 0) { continue; @@ -1330,11 +1406,11 @@ ApplicationType( * known type. */ - attr = GetFileAttributes(nativeFullPath); + attr = (*tclWinProcs->getFileAttributesProc)((TCHAR *) nativeFullPath); if ((attr == 0xffffffff) || (attr & FILE_ATTRIBUTE_DIRECTORY)) { continue; } - strcpy(fullName, Tcl_WinTCharToUtf(nativeFullPath, -1, &ds)); + strcpy(fullName, Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds)); Tcl_DStringFree(&ds); ext = strrchr(fullName, '.'); @@ -1343,7 +1419,7 @@ ApplicationType( break; } - hFile = CreateFile(nativeFullPath, + hFile = (*tclWinProcs->createFileProc)((TCHAR *) nativeFullPath, GENERIC_READ, FILE_SHARE_READ, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); if (hFile == INVALID_HANDLE_VALUE) { @@ -1410,8 +1486,8 @@ ApplicationType( if (applType == APPL_NONE) { TclWinConvertError(GetLastError()); - Tcl_SetObjResult(interp, Tcl_ObjPrintf("couldn't execute \"%s\": %s", - originalName, Tcl_PosixError(interp))); + Tcl_AppendResult(interp, "couldn't execute \"", originalName, + "\": ", Tcl_PosixError(interp), (char *) NULL); return APPL_NONE; } @@ -1423,8 +1499,9 @@ ApplicationType( * application name from the arguments. */ - GetShortPathName(nativeFullPath, nativeFullPath, MAX_PATH); - strcpy(fullName, Tcl_WinTCharToUtf(nativeFullPath, -1, &ds)); + (*tclWinProcs->getShortPathNameProc)((TCHAR *) nativeFullPath, + nativeFullPath, MAX_PATH); + strcpy(fullName, Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds)); Tcl_DStringFree(&ds); } return applType; @@ -1468,9 +1545,9 @@ BuildCommandLine( * Prime the path. Add a space separator if we were primed with something. */ - TclDStringAppendDString(&ds, linePtr); + Tcl_DStringAppend(&ds, Tcl_DStringValue(linePtr), -1); if (Tcl_DStringLength(linePtr) > 0) { - TclDStringAppendLiteral(&ds, " "); + Tcl_DStringAppend(&ds, " ", 1); } for (i = 0; i < argc; i++) { @@ -1478,7 +1555,7 @@ BuildCommandLine( arg = executable; } else { arg = argv[i]; - TclDStringAppendLiteral(&ds, " "); + Tcl_DStringAppend(&ds, " ", 1); } quote = 0; @@ -1487,7 +1564,6 @@ 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. */ @@ -1497,7 +1573,7 @@ BuildCommandLine( } } if (quote) { - TclDStringAppendLiteral(&ds, "\""); + Tcl_DStringAppend(&ds, "\"", 1); } start = arg; for (special = arg; ; ) { @@ -1526,7 +1602,7 @@ BuildCommandLine( } if (*special == '"') { Tcl_DStringAppend(&ds, start, (int) (special - start)); - TclDStringAppendLiteral(&ds, "\\\""); + Tcl_DStringAppend(&ds, "\\\"", 2); start = special + 1; } if (*special == '\0') { @@ -1536,7 +1612,7 @@ BuildCommandLine( } Tcl_DStringAppend(&ds, start, (int) (special - start)); if (quote) { - TclDStringAppendLiteral(&ds, "\""); + Tcl_DStringAppend(&ds, "\"", 1); } } Tcl_DStringFree(linePtr); @@ -1572,7 +1648,7 @@ TclpCreateCommandChannel( { char channelName[16 + TCL_INTEGER_SPACE]; DWORD id; - PipeInfo *infoPtr = ckalloc(sizeof(PipeInfo)); + PipeInfo *infoPtr = (PipeInfo *) ckalloc((unsigned) sizeof(PipeInfo)); PipeInit(); @@ -1587,7 +1663,7 @@ TclpCreateCommandChannel( infoPtr->writeBuf = 0; infoPtr->writeBufLen = 0; infoPtr->writeError = 0; - infoPtr->channel = NULL; + infoPtr->channel = (Tcl_Channel) NULL; infoPtr->validMask = 0; @@ -1629,9 +1705,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, - infoPtr, infoPtr->validMask); + (ClientData) infoPtr, infoPtr->validMask); /* * Pipes have AUTO translation mode on Windows and ^Z eof char, which @@ -1639,58 +1715,16 @@ TclpCreateCommandChannel( * Windows programs that expect a ^Z at EOF. */ - Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto"); - Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}"); + Tcl_SetChannelOption((Tcl_Interp *) NULL, infoPtr->channel, + "-translation", "auto"); + Tcl_SetChannelOption((Tcl_Interp *) 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 @@ -1712,8 +1746,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. @@ -1724,17 +1758,14 @@ TclGetAndDetachPids( return; } - pipePtr = Tcl_GetChannelInstanceData(chan); - TclNewObj(pidsObj); + pipePtr = (PipeInfo *) Tcl_GetChannelInstanceData(chan); for (i = 0; i < pipePtr->numPids; i++) { - Tcl_ListObjAppendElement(NULL, pidsObj, - Tcl_NewWideIntObj((unsigned) - TclpGetPid(pipePtr->pidPtr[i]))); - Tcl_DetachPids(1, &pipePtr->pidPtr[i]); + wsprintfA(buf, "%lu", TclpGetPid(pipePtr->pidPtr[i])); + Tcl_AppendElement(interp, buf); + Tcl_DetachPids(1, &(pipePtr->pidPtr[i])); } - Tcl_SetObjResult(interp, pidsObj); if (pipePtr->numPids > 0) { - ckfree(pipePtr->pidPtr); + ckfree((char *) pipePtr->pidPtr); pipePtr->numPids = 0; } } @@ -1879,26 +1910,12 @@ 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 but blocked during exit, bail out since the worker - * thread is not interruptible and we want TIP#398-fast-exit. + * 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. */ - if (TclInExit() - && (pipePtr->flags & PIPE_ASYNC)) { - - /* give it a chance to leave honorably */ - SetEvent(pipePtr->stopWriter); - if (WaitForSingleObject(pipePtr->writable, 0) == WAIT_TIMEOUT) { - return EAGAIN; - } - - } else { - - WaitForSingleObject(pipePtr->writable, INFINITE); - - } + WaitForSingleObject(pipePtr->writable, INFINITE); /* * The thread may already have closed on it's own. Check its exit @@ -2008,11 +2025,12 @@ PipeClose2Proc( */ if (pipePtr->errorFile) { - WinFile *filePtr = (WinFile *) pipePtr->errorFile; + WinFile *filePtr; + filePtr = (WinFile*)pipePtr->errorFile; errChan = Tcl_MakeFileChannel((ClientData) filePtr->handle, TCL_READABLE); - ckfree(filePtr); + ckfree((char *) filePtr); } else { errChan = NULL; } @@ -2022,14 +2040,14 @@ PipeClose2Proc( } if (pipePtr->numPids > 0) { - ckfree(pipePtr->pidPtr); + ckfree((char *) pipePtr->pidPtr); } if (pipePtr->writeBuf != NULL) { ckfree(pipePtr->writeBuf); } - ckfree(pipePtr); + ckfree((char*) pipePtr); if (errorCode == 0) { return result; @@ -2197,7 +2215,7 @@ PipeOutputProc( ckfree(infoPtr->writeBuf); } infoPtr->writeBufLen = toWrite; - infoPtr->writeBuf = ckalloc(toWrite); + infoPtr->writeBuf = ckalloc((unsigned int) toWrite); } memcpy(infoPtr->writeBuf, buf, (size_t) toWrite); infoPtr->toWrite = toWrite; @@ -2576,7 +2594,7 @@ Tcl_WaitPid( */ CloseHandle(infoPtr->hProcess); - ckfree(infoPtr); + ckfree((char*)infoPtr); return result; } @@ -2602,9 +2620,9 @@ Tcl_WaitPid( void TclWinAddProcess( void *hProcess, /* Handle to process */ - unsigned long id) /* Global process identifier */ + unsigned long id) /* Global process identifier */ { - ProcInfo *procPtr = ckalloc(sizeof(ProcInfo)); + ProcInfo *procPtr = (ProcInfo *) ckalloc(sizeof(ProcInfo)); PipeInit(); @@ -2646,13 +2664,15 @@ Tcl_PidObjCmd( PipeInfo *pipePtr; int i; Tcl_Obj *resultPtr; + char buf[TCL_INTEGER_SPACE]; if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "?channelId?"); return TCL_ERROR; } if (objc == 1) { - Tcl_SetObjResult(interp, Tcl_NewWideIntObj((unsigned) getpid())); + wsprintfA(buf, "%lu", (unsigned long) getpid()); + Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, -1)); } else { chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), NULL); @@ -2667,9 +2687,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_NewWideIntObj((unsigned) - TclpGetPid(pipePtr->pidPtr[i]))); + Tcl_NewStringObj(buf, -1)); } Tcl_SetObjResult(interp, resultPtr); } @@ -2961,10 +2981,6 @@ PipeWriterThread( * an error, so exit. */ - if (waitResult == WAIT_OBJECT_0) { - SetEvent(infoPtr->writable); - } - break; } @@ -3065,100 +3081,6 @@ 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 48f7894..f58014c 100644 --- a/win/tclWinPort.h +++ b/win/tclWinPort.h @@ -14,24 +14,11 @@ #ifndef _TCLWINPORT #define _TCLWINPORT -#if !defined(_WIN64) && defined(BUILD_tcl) +#ifndef _WIN64 /* 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 @@ -47,10 +34,6 @@ 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 @@ -62,34 +45,22 @@ 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. *--------------------------------------------------------------------------- */ -#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 strncasecmp @@ -117,166 +88,108 @@ typedef DWORD_PTR * PDWORD_PTR; #include <time.h> /* + * 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. */ -#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 +#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 */ +/* + * 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. + */ -/* 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 +#undef EOVERFLOW +#define EOVERFLOW EFBIG /* The object couldn't fit in the datatype */ /* * Signals not known to the standard ANSI signal.h. These are used @@ -438,9 +351,9 @@ typedef DWORD_PTR * PDWORD_PTR; #if defined(_MSC_VER) || defined(__MINGW32__) # define environ _environ -# if defined(_MSC_VER) && (_MSC_VER < 1600) +# if defined(_MSC_VER) && (_MSC_VER < 1600) # define hypot _hypot -# endif +# endif # define exception _exception # undef EDEADLOCK # if defined(__MINGW32__) && !defined(__MSVCRT__) @@ -475,6 +388,12 @@ typedef DWORD_PTR * PDWORD_PTR; /* + * 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 * generic and windows-specific parts of Tcl. Some of the macros may diff --git a/win/tclWinReg.c b/win/tclWinReg.c index 327e4a3..a6ce2ce 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -12,57 +12,36 @@ * 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 */ - /* - * Ensure that we can say which registry is being accessed. + * 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. */ -#ifndef KEY_WOW64_64KEY -# define KEY_WOW64_64KEY (0x0100) -#endif -#ifndef KEY_WOW64_32KEY -# define KEY_WOW64_32KEY (0x0200) -#endif +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLEXPORT /* * 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 @@ -76,7 +55,7 @@ * system predefined keys. */ -static const char *const rootKeyNames[] = { +static CONST char *rootKeyNames[] = { "HKEY_LOCAL_MACHINE", "HKEY_USERS", "HKEY_CLASSES_ROOT", "HKEY_CURRENT_USER", "HKEY_CURRENT_CONFIG", "HKEY_PERFORMANCE_DATA", "HKEY_DYN_DATA", NULL @@ -87,7 +66,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 @@ -95,7 +74,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 *const typeNames[] = { +static CONST char *typeNames[] = { "none", "sz", "expand_sz", "binary", "dword", "dword_big_endian", "link", "multi_sz", "resource_list", NULL }; @@ -103,26 +82,100 @@ static const char *const 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, - REGSAM mode); +static int DeleteKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj); static int DeleteValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, - Tcl_Obj *valueNameObj, REGSAM mode); + Tcl_Obj *valueNameObj); static int GetKeyNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj, - Tcl_Obj *patternObj, REGSAM mode); + Tcl_Obj *patternObj); static int GetType(Tcl_Interp *interp, Tcl_Obj *keyNameObj, - Tcl_Obj *valueNameObj, REGSAM mode); + Tcl_Obj *valueNameObj); static int GetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, - Tcl_Obj *valueNameObj, REGSAM mode); + Tcl_Obj *valueNameObj); static int GetValueNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj, - Tcl_Obj *patternObj, REGSAM mode); + Tcl_Obj *patternObj); static int OpenKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj, REGSAM mode, int flags, HKEY *keyPtr); static DWORD OpenSubKey(char *hostName, HKEY rootKey, @@ -132,13 +185,13 @@ static int ParseKeyName(Tcl_Interp *interp, char *name, char **hostNamePtr, HKEY *rootKeyPtr, char **keyNamePtr); static DWORD RecursiveDeleteKey(HKEY hStartKey, - const TCHAR * pKeyName, REGSAM mode); + CONST TCHAR * pKeyName); 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, REGSAM mode); + Tcl_Obj *typeObj); EXTERN int Registry_Init(Tcl_Interp *interp); EXTERN int Registry_Unload(Tcl_Interp *interp, int flags); @@ -165,14 +218,25 @@ Registry_Init( { Tcl_Command cmd; - if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.1", 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, - interp, DeleteCmd); - Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, cmd); - return Tcl_PkgProvide(interp, "registry", "1.3.0"); + (ClientData)interp, DeleteCmd); + Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, (ClientData)cmd); + return Tcl_PkgProvide(interp, "registry", "1.2.2"); } /* @@ -212,7 +276,7 @@ Registry_Unload( * Delete the originally registered command. */ - cmd = Tcl_GetAssocData(interp, REGISTRY_ASSOC_KEY, NULL); + cmd = (Tcl_Command)Tcl_GetAssocData(interp, REGISTRY_ASSOC_KEY, NULL); if (cmd != NULL) { Tcl_DeleteCommandFromToken(interp, cmd); } @@ -242,8 +306,7 @@ DeleteCmd( ClientData clientData) { Tcl_Interp *interp = clientData; - - Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, NULL); + Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, (ClientData)NULL); } /* @@ -267,125 +330,89 @@ 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 n = 1; - int index, argc; - REGSAM mode = 0; - const char *errString = NULL; + int index; + char *errString = NULL; - static const char *const subcommands[] = { + static CONST char *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) { - wrongArgs: - Tcl_WrongNumArgs(interp, 1, objv, "?-32bit|-64bit? option ?arg ...?"); + Tcl_WrongNumArgs(interp, objc, objv, "option ?arg arg ...?"); return TCL_ERROR; } - 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) { + if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "option", 0, &index) + != TCL_OK) { return TCL_ERROR; } - argc = (objc - n); switch (index) { case BroadcastIdx: /* broadcast */ - if (argc == 1 || argc == 3) { - int res = BroadcastValue(interp, argc, objv + n); - - if (res != TCL_BREAK) { - return res; - } - } - errString = "keyName ?-timeout milliseconds?"; + return BroadcastValue(interp, objc, objv); break; case DeleteIdx: /* delete */ - if (argc == 1) { - return DeleteKey(interp, objv[n], mode); - } else if (argc == 2) { - return DeleteValue(interp, objv[n], objv[n+1], mode); + if (objc == 3) { + return DeleteKey(interp, objv[2]); + } else if (objc == 4) { + return DeleteValue(interp, objv[2], objv[3]); } errString = "keyName ?valueName?"; break; case GetIdx: /* get */ - if (argc == 2) { - return GetValue(interp, objv[n], objv[n+1], mode); + if (objc == 4) { + return GetValue(interp, objv[2], objv[3]); } errString = "keyName valueName"; break; case KeysIdx: /* keys */ - if (argc == 1) { - return GetKeyNames(interp, objv[n], NULL, mode); - } else if (argc == 2) { - return GetKeyNames(interp, objv[n], objv[n+1], mode); + if (objc == 3) { + return GetKeyNames(interp, objv[2], NULL); + } else if (objc == 4) { + return GetKeyNames(interp, objv[2], objv[3]); } errString = "keyName ?pattern?"; break; case SetIdx: /* set */ - if (argc == 1) { + if (objc == 3) { HKEY key; /* * Create the key and then close it immediately. */ - mode |= KEY_ALL_ACCESS; - if (OpenKey(interp, objv[n], mode, 1, &key) != TCL_OK) { + if (OpenKey(interp, objv[2], KEY_ALL_ACCESS, 1, &key) != TCL_OK) { return TCL_ERROR; } RegCloseKey(key); return TCL_OK; - } 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); + } else if (objc == 5 || objc == 6) { + Tcl_Obj *typeObj = (objc == 5) ? NULL : objv[5]; + return SetValue(interp, objv[2], objv[3], objv[4], typeObj); } errString = "keyName ?valueName data ?type??"; break; case TypeIdx: /* type */ - if (argc == 2) { - return GetType(interp, objv[n], objv[n+1], mode); + if (objc == 4) { + return GetType(interp, objv[2], objv[3]); } errString = "keyName valueName"; break; case ValuesIdx: /* values */ - if (argc == 1) { - return GetValueNames(interp, objv[n], NULL, mode); - } else if (argc == 2) { - return GetValueNames(interp, objv[n], objv[n+1], mode); + if (objc == 3) { + return GetValueNames(interp, objv[2], NULL); + } else if (objc == 4) { + return GetValueNames(interp, objv[2], objv[3]); } errString = "keyName ?pattern?"; break; } - Tcl_WrongNumArgs(interp, (mode ? 3 : 2), objv, errString); + Tcl_WrongNumArgs(interp, 2, objv, errString); return TCL_ERROR; } @@ -408,23 +435,21 @@ RegistryObjCmd( static int DeleteKey( Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Obj *keyNameObj, /* Name of key to delete. */ - REGSAM mode) /* Mode flags to pass. */ + Tcl_Obj *keyNameObj) /* Name of key to delete. */ { char *tail, *buffer, *hostName, *keyName; - const TCHAR *nativeTail; + CONST char *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(length + 1); + buffer = ckalloc((unsigned int) length + 1); strcpy(buffer, keyName); if (ParseKeyName(interp, buffer, &hostName, &rootKey, @@ -434,9 +459,8 @@ DeleteKey( } if (*keyName == '\0') { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("bad key: cannot delete root keys", -1)); - Tcl_SetErrorCode(interp, "WIN_REG", "DEL_ROOT_KEY", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad key: cannot delete root keys", -1)); ckfree(buffer); return TCL_ERROR; } @@ -449,15 +473,15 @@ DeleteKey( keyName = NULL; } - mode |= KEY_ENUMERATE_SUB_KEYS | DELETE; - result = OpenSubKey(hostName, rootKey, keyName, mode, 0, &subkey); + result = OpenSubKey(hostName, rootKey, keyName, + KEY_ENUMERATE_SUB_KEYS | DELETE, 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; } @@ -467,7 +491,7 @@ DeleteKey( */ nativeTail = Tcl_WinUtfToTChar(tail, -1, &buf); - result = RecursiveDeleteKey(subkey, nativeTail, saveMode); + result = RecursiveDeleteKey(subkey, nativeTail); Tcl_DStringFree(&buf); if (result != ERROR_SUCCESS && result != ERROR_FILE_NOT_FOUND) { @@ -504,8 +528,7 @@ static int DeleteValue( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Obj *keyNameObj, /* Name of key. */ - Tcl_Obj *valueNameObj, /* Name of value to delete. */ - REGSAM mode) /* Mode flags to pass. */ + Tcl_Obj *valueNameObj) /* Name of value to delete. */ { HKEY key; char *valueName; @@ -517,19 +540,19 @@ DeleteValue( * Attempt to open the key for deletion. */ - mode |= KEY_SET_VALUE; - if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) { + if (OpenKey(interp, keyNameObj, KEY_SET_VALUE, 0, &key) + != TCL_OK) { return TCL_ERROR; } valueName = Tcl_GetStringFromObj(valueNameObj, &length); Tcl_WinUtfToTChar(valueName, length, &ds); - result = RegDeleteValue(key, (const TCHAR *)Tcl_DStringValue(&ds)); + result = (*regWinProcs->regDeleteValueProc)(key, Tcl_DStringValue(&ds)); Tcl_DStringFree(&ds); if (result != ERROR_SUCCESS) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unable to delete value \"%s\" from key \"%s\": ", - Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj))); + Tcl_AppendResult(interp, "unable to delete value \"", + Tcl_GetString(valueNameObj), "\" from key \"", + Tcl_GetString(keyNameObj), "\": ", NULL); AppendSystemError(interp, result); result = TCL_ERROR; } else { @@ -562,13 +585,11 @@ static int GetKeyNames( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Obj *keyNameObj, /* Key to enumerate. */ - Tcl_Obj *patternObj, /* Optional match pattern. */ - REGSAM mode) /* Mode flags to pass. */ + Tcl_Obj *patternObj) /* Optional match pattern. */ { - const char *pattern; /* Pattern being matched against subkeys */ + char *pattern; /* Pattern being matched against subkeys */ HKEY key; /* Handle to the key being examined */ - TCHAR buffer[MAX_KEY_LENGTH]; - /* Buffer to hold the subkey name */ + TCHAR buffer[MAX_KEY_LENGTH*2]; /* Buffer to hold the subkey name */ DWORD bufSize; /* Size of the buffer */ DWORD index; /* Position of the current subkey */ char *name; /* Subkey name */ @@ -582,37 +603,39 @@ GetKeyNames( pattern = NULL; } - /* - * Attempt to open the key for enumeration. - */ + /* Attempt to open the key for enumeration. */ - mode |= KEY_QUERY_VALUE | KEY_ENUMERATE_SUB_KEYS; - if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) { + if (OpenKey(interp, keyNameObj, + KEY_QUERY_VALUE | KEY_ENUMERATE_SUB_KEYS, + 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 = RegEnumKeyEx(key, index, buffer, &bufSize, - NULL, NULL, NULL, NULL); + result = (*regWinProcs->regEnumKeyExProc) + (key, index, buffer, &bufSize, NULL, NULL, NULL, NULL); if (result != ERROR_SUCCESS) { if (result == ERROR_NO_MORE_ITEMS) { result = TCL_OK; } else { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unable to enumerate subkeys of \"%s\": ", - Tcl_GetString(keyNameObj))); + Tcl_SetObjResult(interp, Tcl_NewObj()); + Tcl_AppendResult(interp, + "unable to enumerate subkeys of \"", + Tcl_GetString(keyNameObj), "\": ", NULL); AppendSystemError(interp, result); result = TCL_ERROR; } break; } - Tcl_WinTCharToUtf(buffer, bufSize * sizeof(TCHAR), &ds); + if (regWinProcs->useWide) { + Tcl_WinTCharToUtf((TCHAR *) buffer, bufSize * sizeof(WCHAR), &ds); + } else { + Tcl_WinTCharToUtf((TCHAR *) buffer, bufSize, &ds); + } name = Tcl_DStringValue(&ds); if (pattern && !Tcl_StringMatch(name, pattern)) { Tcl_DStringFree(&ds); @@ -656,22 +679,22 @@ static int GetType( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Obj *keyNameObj, /* Name of key. */ - Tcl_Obj *valueNameObj, /* Name of value to get. */ - REGSAM mode) /* Mode flags to pass. */ + Tcl_Obj *valueNameObj) /* Name of value to get. */ { HKEY key; - DWORD result, type; + DWORD result; + DWORD type; Tcl_DString ds; - const char *valueName; - const TCHAR *nativeValue; + char *valueName; + CONST char *nativeValue; int length; /* * Attempt to open the key for reading. */ - mode |= KEY_QUERY_VALUE; - if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) { + if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key) + != TCL_OK) { return TCL_ERROR; } @@ -681,15 +704,15 @@ GetType( valueName = Tcl_GetStringFromObj(valueNameObj, &length); nativeValue = Tcl_WinUtfToTChar(valueName, length, &ds); - result = RegQueryValueEx(key, nativeValue, NULL, &type, + result = (*regWinProcs->regQueryValueExProc)(key, nativeValue, NULL, &type, NULL, NULL); Tcl_DStringFree(&ds); RegCloseKey(key); if (result != ERROR_SUCCESS) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unable to get type of value \"%s\" from key \"%s\": ", - Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj))); + Tcl_AppendResult(interp, "unable to get type of value \"", + Tcl_GetString(valueNameObj), "\" from key \"", + Tcl_GetString(keyNameObj), "\": ", NULL); AppendSystemError(interp, result); return TCL_ERROR; } @@ -728,12 +751,11 @@ static int GetValue( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Obj *keyNameObj, /* Name of key. */ - Tcl_Obj *valueNameObj, /* Name of value to get. */ - REGSAM mode) /* Mode flags to pass. */ + Tcl_Obj *valueNameObj) /* Name of value to get. */ { HKEY key; - const char *valueName; - const TCHAR *nativeValue; + char *valueName; + CONST char *nativeValue; DWORD result, length, type; Tcl_DString data, buf; int nameLen; @@ -742,8 +764,7 @@ GetValue( * Attempt to open the key for reading. */ - mode |= KEY_QUERY_VALUE; - if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) { + if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key) != TCL_OK) { return TCL_ERROR; } @@ -759,12 +780,12 @@ GetValue( Tcl_DStringInit(&data); Tcl_DStringSetLength(&data, TCL_DSTRING_STATIC_SIZE - 1); - length = TCL_DSTRING_STATIC_SIZE/sizeof(TCHAR) - 1; + length = TCL_DSTRING_STATIC_SIZE / (regWinProcs->useWide ? 2 : 1) - 1; valueName = Tcl_GetStringFromObj(valueNameObj, &nameLen); nativeValue = Tcl_WinUtfToTChar(valueName, nameLen, &buf); - result = RegQueryValueEx(key, nativeValue, NULL, &type, + result = (*regWinProcs->regQueryValueExProc)(key, nativeValue, NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length); while (result == ERROR_MORE_DATA) { /* @@ -773,17 +794,17 @@ GetValue( * HKEY_PERFORMANCE_DATA */ - length = Tcl_DStringLength(&data) * (2 / sizeof(TCHAR)); - Tcl_DStringSetLength(&data, (int) length * sizeof(TCHAR)); - result = RegQueryValueEx(key, nativeValue, + length = Tcl_DStringLength(&data) * (regWinProcs->useWide ? 1 : 2); + Tcl_DStringSetLength(&data, (int) length * (regWinProcs->useWide ? 2 : 1)); + result = (*regWinProcs->regQueryValueExProc)(key, (char *) nativeValue, NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length); } Tcl_DStringFree(&buf); RegCloseKey(key); if (result != ERROR_SUCCESS) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unable to get value \"%s\" from key \"%s\": ", - Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj))); + Tcl_AppendResult(interp, "unable to get value \"", + Tcl_GetString(valueNameObj), "\" from key \"", + Tcl_GetString(keyNameObj), "\": ", NULL); AppendSystemError(interp, result); Tcl_DStringFree(&data); return TCL_ERROR; @@ -798,7 +819,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; @@ -810,17 +831,19 @@ GetValue( * we get bogus data. */ - while ((p < end) && *((Tcl_UniChar *) p) != 0) { - Tcl_UniChar *up; - + while (p < end && ((regWinProcs->useWide) + ? *((Tcl_UniChar *)p) : *p) != 0) { Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf); Tcl_ListObjAppendElement(interp, resultPtr, Tcl_NewStringObj(Tcl_DStringValue(&buf), Tcl_DStringLength(&buf))); - up = (Tcl_UniChar *) p; - - while (*up++ != 0) {/* empty body */} - p = (char *) up; + if (regWinProcs->useWide) { + Tcl_UniChar* up = (Tcl_UniChar*) p; + while (*up++ != 0) {} + p = (char*) up; + } else { + while (*p++ != '\0') {} + } Tcl_DStringFree(&buf); } Tcl_SetObjResult(interp, resultPtr); @@ -862,27 +885,27 @@ static int GetValueNames( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Obj *keyNameObj, /* Key to enumerate. */ - Tcl_Obj *patternObj, /* Optional match pattern. */ - REGSAM mode) /* Mode flags to pass. */ + Tcl_Obj *patternObj) /* Optional match pattern. */ { HKEY key; Tcl_Obj *resultPtr; DWORD index, size, result; Tcl_DString buffer, ds; - const char *pattern, *name; + char *pattern, *name; /* * Attempt to open the key for enumeration. */ - mode |= KEY_QUERY_VALUE; - if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) { + if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key) + != TCL_OK) { return TCL_ERROR; } resultPtr = Tcl_NewObj(); Tcl_DStringInit(&buffer); - Tcl_DStringSetLength(&buffer, (int) (MAX_KEY_LENGTH * sizeof(TCHAR))); + Tcl_DStringSetLength(&buffer, + (int) ((regWinProcs->useWide) ? MAX_KEY_LENGTH*2 : MAX_KEY_LENGTH)); index = 0; result = TCL_OK; @@ -899,9 +922,13 @@ GetValueNames( */ size = MAX_KEY_LENGTH; - while (RegEnumValue(key,index, (TCHAR *)Tcl_DStringValue(&buffer), - &size, NULL, NULL, NULL, NULL) == ERROR_SUCCESS) { - size *= sizeof(TCHAR); + while ((*regWinProcs->regEnumValueProc)(key, index, + Tcl_DStringValue(&buffer), &size, NULL, NULL, NULL, NULL) + == ERROR_SUCCESS) { + + if (regWinProcs->useWide) { + size *= 2; + } Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&buffer), (int) size, &ds); @@ -956,7 +983,7 @@ OpenKey( DWORD result; keyName = Tcl_GetStringFromObj(keyNameObj, &length); - buffer = ckalloc(length + 1); + buffer = ckalloc((unsigned int) length + 1); strcpy(buffer, keyName); result = ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName); @@ -1012,7 +1039,7 @@ OpenSubKey( if (hostName) { hostName = (char *) Tcl_WinUtfToTChar(hostName, -1, &buf); - result = RegConnectRegistry((TCHAR *)hostName, rootKey, + result = (*regWinProcs->regConnectRegistryProc)(hostName, rootKey, &rootKey); Tcl_DStringFree(&buf); if (result != ERROR_SUCCESS) { @@ -1028,19 +1055,17 @@ OpenSubKey( keyName = (char *) Tcl_WinUtfToTChar(keyName, -1, &buf); if (flags & REG_CREATE) { DWORD create; - - result = RegCreateKeyEx(rootKey, (TCHAR *)keyName, 0, NULL, + result = (*regWinProcs->regCreateKeyExProc)(rootKey, 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 = RegOpenKeyEx(rootKey, (TCHAR *)keyName, 0, mode, + result = (*regWinProcs->regOpenKeyExProc)(rootKey, keyName, 0, mode, keyPtr); } Tcl_DStringFree(&buf); @@ -1104,9 +1129,8 @@ ParseKeyName( rootName = name; } if (!rootName) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad key \"%s\": must start with a valid root", name)); - Tcl_SetErrorCode(interp, "WIN_REG", "NO_ROOT_KEY", NULL); + Tcl_AppendResult(interp, "bad key \"", name, + "\": must start with a valid root", NULL); return TCL_ERROR; } @@ -1158,16 +1182,12 @@ ParseKeyName( static DWORD RecursiveDeleteKey( HKEY startKey, /* Parent of key to be deleted. */ - const TCHAR *keyName, /* Name of key to be deleted in external + CONST char *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. @@ -1177,50 +1197,29 @@ RecursiveDeleteKey( return ERROR_BADKEY; } - mode |= KEY_ENUMERATE_SUB_KEYS | DELETE | KEY_QUERY_VALUE; - result = RegOpenKeyEx(startKey, keyName, 0, mode, &hKey); + result = (*regWinProcs->regOpenKeyExProc)(startKey, keyName, 0, + KEY_ENUMERATE_SUB_KEYS | DELETE | KEY_QUERY_VALUE, &hKey); if (result != ERROR_SUCCESS) { return result; } Tcl_DStringInit(&subkey); - Tcl_DStringSetLength(&subkey, (int) (MAX_KEY_LENGTH * sizeof(TCHAR))); + Tcl_DStringSetLength(&subkey, + (int) ((regWinProcs->useWide) ? MAX_KEY_LENGTH * 2 : MAX_KEY_LENGTH)); - mode = saveMode; while (result == ERROR_SUCCESS) { /* * Always get index 0 because key deletion changes ordering. */ size = MAX_KEY_LENGTH; - result = RegEnumKeyEx(hKey, 0, (TCHAR *)Tcl_DStringValue(&subkey), - &size, NULL, NULL, NULL, NULL); + result=(*regWinProcs->regEnumKeyExProc)(hKey, 0, + Tcl_DStringValue(&subkey), &size, NULL, NULL, NULL, NULL); if (result == ERROR_NO_MORE_ITEMS) { - /* - * RegDeleteKeyEx doesn't exist on non-64bit XP platforms, so we - * can't compile with it in. We need to check for it at runtime - * and use it if we find it. - */ - - if (mode && !checkExProc) { - 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); - } + result = (*regWinProcs->regDeleteKeyProc)(startKey, keyName); break; } else if (result == ERROR_SUCCESS) { - result = RecursiveDeleteKey(hKey, - (const TCHAR *) Tcl_DStringValue(&subkey), mode); + result = RecursiveDeleteKey(hKey, Tcl_DStringValue(&subkey)); } } Tcl_DStringFree(&subkey); @@ -1252,26 +1251,25 @@ 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. */ - REGSAM mode) /* Mode flags to pass. */ + Tcl_Obj *typeObj) /* Type of data to be written. */ { - int type, length; + int type; DWORD result; HKEY key; - const char *valueName; + int length; + 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); } - mode |= KEY_ALL_ACCESS; - if (OpenKey(interp, keyNameObj, mode, 1, &key) != TCL_OK) { + if (OpenKey(interp, keyNameObj, KEY_ALL_ACCESS, 1, &key) != TCL_OK) { return TCL_ERROR; } @@ -1287,8 +1285,8 @@ SetValue( return TCL_ERROR; } - value = ConvertDWORD((DWORD) type, (DWORD) value); - result = RegSetValueEx(key, (TCHAR *) valueName, 0, + value = ConvertDWORD((DWORD)type, (DWORD)value); + result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, (DWORD) type, (BYTE *) &value, sizeof(DWORD)); } else if (type == REG_MULTI_SZ) { Tcl_DString data, buf; @@ -1309,39 +1307,42 @@ SetValue( Tcl_DStringInit(&data); for (i = 0; i < objc; i++) { - const char *bytes = Tcl_GetStringFromObj(objv[i], &length); - - Tcl_DStringAppend(&data, bytes, length); + Tcl_DStringAppend(&data, Tcl_GetString(objv[i]), -1); /* - * Add a null character to separate this value from the next. + * 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. */ - Tcl_DStringAppend(&data, "", 1); /* NUL-terminated string */ + Tcl_DStringSetLength(&data, Tcl_DStringLength(&data)+1); } Tcl_WinUtfToTChar(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1, &buf); - result = RegSetValueEx(key, (TCHAR *) valueName, 0, - (DWORD) type, (BYTE *) Tcl_DStringValue(&buf), + result = (*regWinProcs->regSetValueExProc)(key, 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 = (char *) Tcl_WinUtfToTChar(data, length, &buf); + data = Tcl_WinUtfToTChar(data, length, &buf); /* * Include the null in the length, padding if needed for Unicode. */ - Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1); + if (regWinProcs->useWide) { + Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1); + } length = Tcl_DStringLength(&buf) + 1; - result = RegSetValueEx(key, (TCHAR *) valueName, 0, - (DWORD) type, (BYTE *) data, (DWORD) length); + result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, + (DWORD) type, (BYTE *) data, (DWORD) length); Tcl_DStringFree(&buf); } else { BYTE *data; @@ -1351,8 +1352,8 @@ SetValue( */ data = (BYTE *) Tcl_GetByteArrayFromObj(dataObj, &length); - result = RegSetValueEx(key, (TCHAR *) valueName, 0, - (DWORD) type, data, (DWORD) length); + result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, + (DWORD) type, data, (DWORD) length); } Tcl_DStringFree(&nameBuf); @@ -1388,27 +1389,33 @@ static int BroadcastValue( Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument values. */ + Tcl_Obj *CONST objv[]) /* Argument values. */ { LRESULT result; DWORD_PTR sendResult; UINT timeout = 3000; int len; - const char *str; + CONST char *str; Tcl_Obj *objPtr; - if (objc == 3) { - str = Tcl_GetStringFromObj(objv[1], &len); + if ((objc != 3) && (objc != 5)) { + Tcl_WrongNumArgs(interp, 2, objv, "keyName ?-timeout millisecs?"); + return TCL_ERROR; + } + + if (objc > 3) { + str = Tcl_GetStringFromObj(objv[3], &len); if ((len < 2) || (*str != '-') || strncmp(str, "-timeout", (size_t) len)) { - return TCL_BREAK; + Tcl_WrongNumArgs(interp, 2, objv, "keyName ?-timeout millisecs?"); + return TCL_ERROR; } - if (Tcl_GetIntFromObj(interp, objv[2], (int *) &timeout) != TCL_OK) { + if (Tcl_GetIntFromObj(interp, objv[4], (int *) &timeout) != TCL_OK) { return TCL_ERROR; } } - str = Tcl_GetStringFromObj(objv[0], &len); + str = Tcl_GetStringFromObj(objv[2], &len); if (len == 0) { str = NULL; } @@ -1417,7 +1424,7 @@ BroadcastValue( * Use the ignore the result. */ - result = SendMessageTimeoutA(HWND_BROADCAST, WM_SETTINGCHANGE, + result = SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, (WPARAM) 0, (LPARAM) str, SMTO_ABORTIFHUNG, timeout, &sendResult); objPtr = Tcl_NewObj(); @@ -1451,8 +1458,8 @@ AppendSystemError( DWORD error) /* Result code from error. */ { int length; - TCHAR *tMsgPtr, **tMsgPtrPtr = &tMsgPtr; - const char *msg; + WCHAR *wMsgPtr, **wMsgPtrPtr = &wMsgPtr; + char *msg; char id[TCL_INTEGER_SPACE], msgBuf[24 + TCL_INTEGER_SPACE]; Tcl_DString ds; Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); @@ -1460,34 +1467,52 @@ AppendSystemError( if (Tcl_IsShared(resultPtr)) { resultPtr = Tcl_DuplicateObj(resultPtr); } - length = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM + length = FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error, - MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (TCHAR *) tMsgPtrPtr, + MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (WCHAR *) wMsgPtrPtr, 0, NULL); if (length == 0) { - sprintf(msgBuf, "unknown error: %ld", error); - msg = msgBuf; - } else { char *msgPtr; - Tcl_WinTCharToUtf(tMsgPtr, -1, &ds); - LocalFree(tMsgPtr); + 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; + } + } else { + Tcl_Encoding encoding; + + encoding = Tcl_GetEncoding(NULL, "unicode"); + Tcl_ExternalToUtfDString(encoding, (char *) wMsgPtr, -1, &ds); + Tcl_FreeEncoding(encoding); + LocalFree(wMsgPtr); - msgPtr = Tcl_DStringValue(&ds); + msg = Tcl_DStringValue(&ds); length = Tcl_DStringLength(&ds); /* * Trim the trailing CR/LF from the system message. */ - if (msgPtr[length-1] == '\n') { - --length; + if (msg[length-1] == '\n') { + msg[--length] = 0; } - if (msgPtr[length-1] == '\r') { - --length; + if (msg[length-1] == '\r') { + msg[--length] = 0; } - msgPtr[length] = 0; - msg = msgPtr; } sprintf(id, "%ld", error); @@ -1522,15 +1547,14 @@ ConvertDWORD( DWORD type, /* Either REG_DWORD or REG_DWORD_BIG_ENDIAN */ DWORD value) /* The value to be converted. */ { - const DWORD order = 1; + DWORD order = 1; DWORD localType; /* * Check to see if the low bit is in the first byte. */ - localType = (*((const char *) &order) == 1) - ? REG_DWORD : REG_DWORD_BIG_ENDIAN; + localType = (*((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 75d5ffc..d5244ac 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 const Tcl_ChannelType serialChannelType = { +static Tcl_ChannelType serialChannelType = { "serial", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ SerialCloseProc, /* Close proc. */ @@ -214,7 +214,7 @@ static const 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; - Tcl_GetTime(&time); + TclpGetTime(&time); return (time.sec * 1000 + time.usec / 1000); } @@ -527,7 +527,7 @@ SerialCheckProc( if (needEvent) { infoPtr->flags |= SERIAL_PENDING; - evPtr = ckalloc(sizeof(SerialEvent)); + evPtr = (SerialEvent *) 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(serialPtr); + ckfree((char*) 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 = EAGAIN; + errno = EWOULDBLOCK; goto error1; } @@ -1071,7 +1071,7 @@ SerialOutputProc( ckfree(infoPtr->writeBuf); } infoPtr->writeBufLen = toWrite; - infoPtr->writeBuf = ckalloc(toWrite); + infoPtr->writeBuf = ckalloc((unsigned int) 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 = CreateFile(name, access, 0, 0, OPEN_EXISTING, - FILE_FLAG_OVERLAPPED, 0); + handle = (*tclWinProcs->createFileProc)(name, access, 0, 0, + OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0); return handle; } @@ -1476,7 +1476,7 @@ TclWinOpenSerialChannel( SerialInit(); - infoPtr = ckalloc(sizeof(SerialInfo)); + infoPtr = (SerialInfo *) ckalloc((unsigned) 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, - infoPtr, permissions); + (ClientData) 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,18 +1671,19 @@ SerialSetOptionProc( if ((len > 2) && (strncmp(optionName, "-mode", len) == 0)) { if (!GetCommState(infoPtr->handle, &dcb)) { - goto getStateFailed; + if (interp != NULL) { + Tcl_AppendResult(interp, "can't get comm state", NULL); + } + return TCL_ERROR; } native = Tcl_WinUtfToTChar(value, -1, &ds); - result = BuildCommDCB(native, &dcb); + result = (*tclWinProcs->buildCommDCBProc)(native, &dcb); Tcl_DStringFree(&ds); if (result == FALSE) { if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad value \"%s\" for -mode: should be baud,parity,data,stop", - value)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL); + Tcl_AppendResult(interp, "bad value \"", value, + "\" for -mode: should be baud,parity,data,stop", NULL); } return TCL_ERROR; } @@ -1697,7 +1698,10 @@ SerialSetOptionProc( dcb.fAbortOnError = FALSE; if (!SetCommState(infoPtr->handle, &dcb)) { - goto setStateFailed; + if (interp != NULL) { + Tcl_AppendResult(interp, "can't set comm state", NULL); + } + return TCL_ERROR; } return TCL_OK; } @@ -1708,7 +1712,10 @@ SerialSetOptionProc( if ((len > 1) && (strncmp(optionName, "-handshake", len) == 0)) { if (!GetCommState(infoPtr->handle, &dcb)) { - goto getStateFailed; + if (interp != NULL) { + Tcl_AppendResult(interp, "can't get comm state", NULL); + } + return TCL_ERROR; } /* @@ -1743,16 +1750,18 @@ SerialSetOptionProc( dcb.fDtrControl = DTR_CONTROL_HANDSHAKE; } else { if (interp != 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); + Tcl_AppendResult(interp, "bad value \"", value, + "\" for -handshake: must be one of xonxoff, rtscts, " + "dtrdsr or none", NULL); } return TCL_ERROR; } if (!SetCommState(infoPtr->handle, &dcb)) { - goto setStateFailed; + if (interp != NULL) { + Tcl_AppendResult(interp, "can't set comm state", NULL); + } + return TCL_ERROR; } return TCL_OK; } @@ -1763,7 +1772,10 @@ SerialSetOptionProc( if ((len > 1) && (strncmp(optionName, "-xchar", len) == 0)) { if (!GetCommState(infoPtr->handle, &dcb)) { - goto getStateFailed; + if (interp != NULL) { + Tcl_AppendResult(interp, "can't get comm state", NULL); + } + return TCL_ERROR; } if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) { @@ -1772,12 +1784,11 @@ SerialSetOptionProc( if (argc != 2) { badXchar: if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "bad value for -xchar: should be a list of" - " two elements with each a single character", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "XCHAR", NULL); + Tcl_AppendResult(interp, "bad value for -xchar: should be " + "a list of two elements with each a single character", + NULL); } - ckfree(argv); + ckfree((char *) argv); return TCL_ERROR; } @@ -1808,10 +1819,13 @@ SerialSetOptionProc( } dcb.XoffChar = (char) character; } - ckfree(argv); + ckfree((char *) argv); if (!SetCommState(infoPtr->handle, &dcb)) { - goto setStateFailed; + if (interp != NULL) { + Tcl_AppendResult(interp, "can't set comm state", NULL); + } + return TCL_ERROR; } return TCL_OK; } @@ -1828,12 +1842,11 @@ SerialSetOptionProc( } if ((argc % 2) == 1) { if (interp != 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); + Tcl_AppendResult(interp, "bad value \"", value, + "\" for -ttycontrol: should be a list of " + "signal,value pairs", NULL); } - ckfree(argv); + ckfree((char *) argv); return TCL_ERROR; } @@ -1846,10 +1859,7 @@ SerialSetOptionProc( if (!EscapeCommFunction(infoPtr->handle, (DWORD) (flag ? SETDTR : CLRDTR))) { if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can't set DTR signal", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", - "FCONFIGURE", "TTY_SIGNAL", NULL); + Tcl_AppendResult(interp, "can't set DTR signal", NULL); } result = TCL_ERROR; break; @@ -1858,10 +1868,7 @@ SerialSetOptionProc( if (!EscapeCommFunction(infoPtr->handle, (DWORD) (flag ? SETRTS : CLRRTS))) { if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can't set RTS signal", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", - "FCONFIGURE", "TTY_SIGNAL", NULL); + Tcl_AppendResult(interp, "can't set RTS signal", NULL); } result = TCL_ERROR; break; @@ -1870,20 +1877,15 @@ SerialSetOptionProc( if (!EscapeCommFunction(infoPtr->handle, (DWORD) (flag ? SETBREAK : CLRBREAK))) { if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can't set BREAK signal", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", - "FCONFIGURE", "TTY_SIGNAL", NULL); + Tcl_AppendResult(interp,"can't set BREAK signal",NULL); } result = TCL_ERROR; break; } } else { if (interp != NULL) { - 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", + Tcl_AppendResult(interp, "bad signal name \"", argv[i], + "\" for -ttycontrol: must be DTR, RTS or BREAK", NULL); } result = TCL_ERROR; @@ -1891,7 +1893,7 @@ SerialSetOptionProc( } } - ckfree(argv); + ckfree((char *) argv); return result; } @@ -1917,24 +1919,20 @@ SerialSetOptionProc( inSize = atoi(argv[0]); outSize = atoi(argv[1]); } - ckfree(argv); + ckfree((char *) argv); if ((argc < 1) || (argc > 2) || (inSize <= 0) || (outSize <= 0)) { if (interp != 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); + Tcl_AppendResult(interp, "bad value \"", value, + "\" for -sysbuffer: should be a list of one or two " + "integers > 0", NULL); } return TCL_ERROR; } if (!SetupComm(infoPtr->handle, inSize, outSize)) { if (interp != NULL) { - TclWinConvertError(GetLastError()); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't setup comm buffers: %s", - Tcl_PosixError(interp))); + Tcl_AppendResult(interp, "can't setup comm buffers", NULL); } return TCL_ERROR; } @@ -1947,12 +1945,18 @@ SerialSetOptionProc( */ if (!GetCommState(infoPtr->handle, &dcb)) { - goto getStateFailed; + if (interp != NULL) { + Tcl_AppendResult(interp, "can't get comm state", NULL); + } + return TCL_ERROR; } dcb.XonLim = (WORD) (infoPtr->sysBufRead*1/2); dcb.XoffLim = (WORD) (infoPtr->sysBufRead*1/4); if (!SetCommState(infoPtr->handle, &dcb)) { - goto setStateFailed; + if (interp != NULL) { + Tcl_AppendResult(interp, "can't set comm state", NULL); + } + return TCL_ERROR; } return TCL_OK; } @@ -1982,10 +1986,7 @@ SerialSetOptionProc( tout.ReadTotalTimeoutConstant = msec; if (!SetCommTimeouts(infoPtr->handle, &tout)) { if (interp != NULL) { - TclWinConvertError(GetLastError()); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't set comm timeouts: %s", - Tcl_PosixError(interp))); + Tcl_AppendResult(interp, "can't set comm timeouts", NULL); } return TCL_ERROR; } @@ -1995,22 +1996,6 @@ 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; } /* @@ -2038,7 +2023,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; @@ -2063,14 +2048,12 @@ SerialGetOptionProc( } if (len==0 || (len>2 && (strncmp(optionName, "-mode", len) == 0))) { char parity; - const char *stop; + char *stop; char buf[2 * TCL_INTEGER_SPACE + 16]; if (!GetCommState(infoPtr->handle, &dcb)) { if (interp != NULL) { - TclWinConvertError(GetLastError()); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't get comm state: %s", Tcl_PosixError(interp))); + Tcl_AppendResult(interp, "can't get comm state", NULL); } return TCL_ERROR; } @@ -2138,9 +2121,7 @@ SerialGetOptionProc( if (!GetCommState(infoPtr->handle, &dcb)) { if (interp != NULL) { - TclWinConvertError(GetLastError()); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't get comm state: %s", Tcl_PosixError(interp))); + Tcl_AppendResult(interp, "can't get comm state", NULL); } return TCL_ERROR; } @@ -2216,9 +2197,7 @@ SerialGetOptionProc( if (!GetCommModemStatus(infoPtr->handle, &status)) { if (interp != NULL) { - TclWinConvertError(GetLastError()); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't get tty status: %s", Tcl_PosixError(interp))); + Tcl_AppendResult(interp, "can't get tty status", NULL); } return TCL_ERROR; } @@ -2228,9 +2207,10 @@ 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 1a74354..9fa01c9 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -47,13 +47,6 @@ #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 @@ -81,7 +74,6 @@ */ static int initialized = 0; -static const TCHAR classname[] = TEXT("TclSocket"); TCL_DECLARE_MUTEX(socketMutex) /* @@ -97,44 +89,20 @@ 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 - -/* - * 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; +#define SOCKET_MESSAGE WM_USER+1 +#define SOCKET_SELECT WM_USER+2 +#define SOCKET_TERMINATE WM_USER+3 +#define SELECT TRUE +#define UNSELECT FALSE /* * The following structure is used to store the data associated with each * socket. */ -struct SocketInfo { +typedef struct SocketInfo { Tcl_Channel channel; /* Channel associated with this socket. */ - struct TcpFdList *sockets; /* Windows SOCKET handle. */ + SOCKET socket; /* Windows SOCKET handle. */ int flags; /* Bit field comprised of the flags described * below. */ int watchEvents; /* OR'ed combination of FD_READ, FD_WRITE, @@ -155,7 +123,7 @@ 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 @@ -213,13 +181,15 @@ 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(TcpFdList *fds, SOCKET newSocket, address addr); +static void TcpAccept(SocketInfo *infoPtr); static int WaitForSocketEvent(SocketInfo *infoPtr, int events, int *errorCodePtr); static DWORD WINAPI SocketThread(LPVOID arg); @@ -231,7 +201,6 @@ 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; @@ -244,7 +213,7 @@ static Tcl_DriverGetHandleProc TcpGetHandleProc; * based IO. */ -static const Tcl_ChannelType tcpChannelType = { +static Tcl_ChannelType tcpChannelType = { "tcp", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ TcpCloseProc, /* Close proc. */ @@ -255,13 +224,13 @@ static const Tcl_ChannelType tcpChannelType = { TcpGetOptionProc, /* Get option proc. */ TcpWatchProc, /* Set up notifier to watch this channel. */ TcpGetHandleProc, /* Get an OS handle from channel. */ - TcpClose2Proc, /* Close2proc. */ + NULL, /* close2proc. */ TcpBlockProc, /* Set socket into (non-)blocking mode. */ NULL, /* flush proc. */ NULL, /* handler proc. */ NULL, /* wide seek proc */ TcpThreadActionProc, /* thread action proc */ - NULL /* truncate */ + NULL, /* truncate */ }; /* @@ -287,13 +256,15 @@ static const Tcl_ChannelType tcpChannelType = { static void InitSockets(void) { - DWORD id, err; + DWORD id; WSADATA wsaData; - ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + DWORD err; + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) + TclThreadDataKeyGet(&dataKey); if (!initialized) { initialized = 1; - TclCreateLateExitHandler(SocketExitHandler, NULL); + TclCreateLateExitHandler(SocketExitHandler, (ClientData) NULL); /* * Create the async notification window with a new class. We must @@ -308,12 +279,12 @@ InitSockets(void) windowClass.hInstance = TclWinGetTclInstance(); windowClass.hbrBackground = NULL; windowClass.lpszMenuName = NULL; - windowClass.lpszClassName = classname; + windowClass.lpszClassName = "TclSocket"; windowClass.lpfnWndProc = SocketProc; windowClass.hIcon = NULL; windowClass.hCursor = NULL; - if (!RegisterClass(&windowClass)) { + if (!RegisterClassA(&windowClass)) { TclWinConvertError(GetLastError()); goto initFailure; } @@ -324,73 +295,72 @@ InitSockets(void) * that it not be less than 1.1. */ - err = WSAStartup((WORD) MAKEWORD(WSA_VERSION_MAJOR,WSA_VERSION_MINOR), - &wsaData); +#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); if (err != 0) { - TclWinConvertError(err); + TclWinConvertWSAError(err); goto initFailure; } /* - * 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. + * 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. */ if (MAKEWORD(HIBYTE(wsaData.wVersion), LOBYTE(wsaData.wVersion)) < MAKEWORD(WSA_VERSION_MINOR, WSA_VERSION_MAJOR)) { - TclWinConvertError(WSAVERNOTSUPPORTED); + TclWinConvertWSAError(WSAVERNOTSUPPORTED); WSACleanup(); goto initFailure; } + +#undef WSA_VERSION_REQD +#undef WSA_VERSION_MAJOR +#undef WSA_VERSION_MINOR } /* * Check for per-thread initialization. */ - if (tsdPtr != NULL) { - return; - } - - /* - * OK, this thread has never done anything with sockets before. Construct - * a worker thread to handle asynchronous events related to sockets - * assigned to _this_ thread. - */ + if (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; + } - 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; - } + SetThreadPriority(tsdPtr->socketThread, THREAD_PRIORITY_HIGHEST); - SetThreadPriority(tsdPtr->socketThread, THREAD_PRIORITY_HIGHEST); + /* + * Wait for the thread to signal when the window has been created and + * if it is ready to go. + */ - /* - * Wait for the thread to signal when the window has been created and if - * it is ready to go. - */ + WaitForSingleObject(tsdPtr->readyEvent, INFINITE); - WaitForSingleObject(tsdPtr->readyEvent, INFINITE); + if (tsdPtr->hwnd == NULL) { + goto initFailure; /* Trouble creating the window */ + } - if (tsdPtr->hwnd == NULL) { - goto initFailure; /* Trouble creating the window. */ + Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL); } - - Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL); return; initFailure: @@ -420,7 +390,6 @@ static int SocketsEnabled(void) { int enabled; - Tcl_MutexLock(&socketMutex); enabled = (initialized == 1); Tcl_MutexUnlock(&socketMutex); @@ -451,14 +420,13 @@ 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(classname, TclWinGetTclInstance()); + UnregisterClass("TclSocket", TclWinGetTclInstance()); WSACleanup(); initialized = 0; Tcl_MutexUnlock(&socketMutex); @@ -486,40 +454,34 @@ SocketExitHandler( void TclpFinalizeSockets(void) { - ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); - - /* - * 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. - */ + ThreadSpecificData *tsdPtr; - WaitForSingleObject(tsdPtr->readyEvent, INFINITE); - tsdPtr->hwnd = NULL; + 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; } - 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; + 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); } - Tcl_DeleteEventSource(SocketSetupProc, SocketCheckProc, NULL); } /* @@ -557,8 +519,8 @@ TclpHasSockets( return TCL_OK; } if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "sockets are not available on this system", -1)); + Tcl_AppendResult(interp, "sockets are not available on this system", + NULL); } return TCL_ERROR; } @@ -650,9 +612,9 @@ SocketCheckProc( if ((infoPtr->readyEvents & infoPtr->watchEvents) && !(infoPtr->flags & SOCKET_PENDING)) { infoPtr->flags |= SOCKET_PENDING; - evPtr = ckalloc(sizeof(SocketEvent)); + evPtr = (SocketEvent *) ckalloc(sizeof(SocketEvent)); evPtr->header.proc = SocketEventProc; - evPtr->socket = infoPtr->sockets->fd; + evPtr->socket = infoPtr->socket; Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); } } @@ -688,12 +650,9 @@ SocketEventProc( { SocketInfo *infoPtr; SocketEvent *eventPtr = (SocketEvent *) evPtr; - int mask = 0, events; + int mask = 0; + int events; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - TcpFdList *fds; - SOCKET newSocket; - address addr; - int len; if (!(flags & TCL_FILE_EVENTS)) { return 0; @@ -706,17 +665,17 @@ SocketEventProc( WaitForSingleObject(tsdPtr->socketListLock, INFINITE); for (infoPtr = tsdPtr->socketList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { - if (infoPtr->sockets->fd == eventPtr->socket) { + if (infoPtr->socket == eventPtr->socket) { break; } } + SetEvent(tsdPtr->socketListLock); /* * Discard events that have gone stale. */ if (!infoPtr) { - SetEvent(tsdPtr->socketListLock); return 1; } @@ -727,66 +686,10 @@ SocketEventProc( */ if (infoPtr->readyEvents & FD_ACCEPT) { - 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); + TcpAccept(infoPtr); return 1; } - SetEvent(tsdPtr->socketListLock); - /* * Mask off unwanted events and compute the read/write mask so we can * notify the channel. @@ -806,7 +709,6 @@ SocketEventProc( */ Tcl_Time blockTime = { 0, 0 }; - Tcl_SetMaxBlockTime(&blockTime); mask |= TCL_READABLE|TCL_WRITABLE; } else if (events & FD_READ) { @@ -825,7 +727,7 @@ SocketEventProc( (WPARAM) UNSELECT, (LPARAM) infoPtr); FD_ZERO(&readFds); - FD_SET(infoPtr->sockets->fd, &readFds); + FD_SET(infoPtr->socket, &readFds); timeout.tv_usec = 0; timeout.tv_sec = 0; @@ -876,7 +778,7 @@ TcpBlockProc( int mode) /* TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ { - SocketInfo *infoPtr = instanceData; + SocketInfo *infoPtr = (SocketInfo *) instanceData; if (mode == TCL_MODE_NONBLOCKING) { infoPtr->flags |= SOCKET_ASYNC; @@ -910,7 +812,7 @@ TcpCloseProc( ClientData instanceData, /* The socket to close. */ Tcl_Interp *interp) /* Unused. */ { - SocketInfo *infoPtr = instanceData; + SocketInfo *infoPtr = (SocketInfo *) instanceData; /* TIP #218 */ int errorCode = 0; /* ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); */ @@ -928,15 +830,9 @@ TcpCloseProc( * background. */ - 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); + if (closesocket(infoPtr->socket) == SOCKET_ERROR) { + TclWinConvertWSAError((DWORD) WSAGetLastError()); + errorCode = Tcl_GetErrno(); } } @@ -947,113 +843,13 @@ TcpCloseProc( * fear of damaging the list. */ - 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(); - } - + ckfree((char *) infoPtr); 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. @@ -1071,11 +867,12 @@ static SocketInfo * NewSocketInfo( SOCKET socket) { - SocketInfo *infoPtr = ckalloc(sizeof(SocketInfo)); - + SocketInfo *infoPtr; /* ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); */ + + infoPtr = (SocketInfo *) ckalloc((unsigned) sizeof(SocketInfo)); infoPtr->channel = 0; - infoPtr->sockets = NULL; + infoPtr->socket = socket; infoPtr->flags = 0; infoPtr->watchEvents = 0; infoPtr->readyEvents = 0; @@ -1093,8 +890,6 @@ NewSocketInfo( infoPtr->nextPtr = NULL; - AddSocketInfoFd(infoPtr, socket); - return infoPtr; } @@ -1130,15 +925,12 @@ CreateSocket( u_long flag = 1; /* Indicates nonblocking mode. */ int asyncConnect = 0; /* Will be 1 if async connect is in * progress. */ - unsigned short chosenport = 0; - struct addrinfo *addrlist = NULL, *addrPtr; - /* Socket address to connect to. */ - struct addrinfo *myaddrlist = NULL, *myaddrPtr; - /* Socket address for our side. */ - const char *errorMsg = NULL; + SOCKADDR_IN sockaddr; /* Socket address */ + SOCKADDR_IN mysockaddr; /* Socket address for client */ SOCKET sock = INVALID_SOCKET; - SocketInfo *infoPtr = NULL; /* The returned value. */ - ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + SocketInfo *infoPtr; /* The returned value. */ + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) + TclThreadDataKeyGet(&dataKey); /* * Check that WinSock is initialized; do not call it if not, to prevent @@ -1150,195 +942,112 @@ CreateSocket( return NULL; } - /* - * Construct the addresses for each end of the socket. - */ - - if (!TclCreateSocketAddress(interp, &addrlist, host, port, server, - &errorMsg)) { + if (!CreateSocketAddress(&sockaddr, host, port)) { goto error; } - if (!TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1, - &errorMsg)) { + if ((myaddr != NULL || myport != 0) && + !CreateSocketAddress(&mysockaddr, myaddr, myport)) { goto error; } - if (server) { - - 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; - } - - /* - * Win-NT has a misfeature that sockets are inherited in child - * processes by default. Turn off the inherit bit. - */ - - SetHandleInformation((HANDLE) sock, HANDLE_FLAG_INHERIT, 0); - - /* - * Set kernel space buffering - */ + sock = socket(AF_INET, SOCK_STREAM, 0); + if (sock == INVALID_SOCKET) { + goto error; + } - TclSockMinimumBuffers((void *)sock, TCP_BUFFER_SIZE); + /* + * Win-NT has a misfeature that sockets are inherited in child processes + * by default. Turn off the inherit bit. + */ - /* - * 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. - */ + SetHandleInformation((HANDLE) sock, HANDLE_FLAG_INHERIT, 0); - if (port == 0 && chosenport != 0) { - ((struct sockaddr_in *) addrPtr->ai_addr)->sin_port = - htons(chosenport); - } + /* + * Set kernel space buffering + */ - /* - * 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. - */ + TclSockMinimumBuffers((void *)sock, TCP_BUFFER_SIZE); - 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); + 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. + */ - /* - * Synchronize port numbers when binding to port 0 of multiple - * addresses. - */ + if (bind(sock, (SOCKADDR *) &sockaddr, sizeof(SOCKADDR_IN)) + == SOCKET_ERROR) { + goto error; + } - if (getsockname(sock, &sockname.sa, &namelen) >= 0) { - chosenport = ntohs(sockname.sa4.sin_port); - } - } + /* + * Set the maximum number of pending connect requests to the max value + * allowed on each platform (Win32 and Win32s may be different, and + * there may be differences between TCP/IP stacks). + */ - /* - * Set the maximum number of pending connect requests to the max - * value allowed on each platform (Win32 and Win32s may be - * different, and there may be differences between TCP/IP stacks). - */ + if (listen(sock, SOMAXCONN) == SOCKET_ERROR) { + goto error; + } - if (listen(sock, SOMAXCONN) == SOCKET_ERROR) { - TclWinConvertError((DWORD) WSAGetLastError()); - closesocket(sock); - continue; - } + /* + * Add this socket to the global list of sockets. + */ - if (infoPtr == NULL) { - /* - * Add this socket to the global list of sockets. - */ + infoPtr = NewSocketInfo(sock); - infoPtr = NewSocketInfo(sock); + /* + * Set up the select mask for connection request events. + */ - /* - * Set up the select mask for connection request events. - */ + infoPtr->selectEvents = FD_ACCEPT; + infoPtr->watchEvents |= FD_ACCEPT; - infoPtr->selectEvents = FD_ACCEPT; - infoPtr->watchEvents |= FD_ACCEPT; + } else { + /* + * Try to bind to a local port, if specified. + */ - } else { - AddSocketInfoFd( infoPtr, sock ); + if (myaddr != NULL || myport != 0) { + if (bind(sock, (SOCKADDR *) &mysockaddr, sizeof(SOCKADDR_IN)) + == SOCKET_ERROR) { + goto error; } } - } 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. - */ - - if (myaddrPtr->ai_family != addrPtr->ai_family) { - continue; - } - - sock = socket(myaddrPtr->ai_family, SOCK_STREAM, 0); - if (sock == INVALID_SOCKET) { - TclWinConvertError((DWORD) WSAGetLastError()); - continue; - } - - /* - * Win-NT has a misfeature that sockets are inherited in child - * processes by default. Turn off the inherit bit. - */ - - SetHandleInformation((HANDLE) sock, HANDLE_FLAG_INHERIT, 0); - - /* - * Set kernel space buffering - */ - - TclSockMinimumBuffers((void *) sock, TCP_BUFFER_SIZE); - /* - * 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; - } + /* + * Set the socket into nonblocking mode if the connect should be done + * in the background. + */ - /* - * Attempt to connect to the remote socket. - */ + if (async) { + if (ioctlsocket(sock, (long) FIONBIO, &flag) == SOCKET_ERROR) { + goto error; + } + } - if (connect(sock, addrPtr->ai_addr, addrPtr->ai_addrlen) - == SOCKET_ERROR) { - TclWinConvertError((DWORD) WSAGetLastError()); - if (Tcl_GetErrno() != EAGAIN) { - goto looperror; - } + /* + * Attempt to connect to the remote socket. + */ - /* - * The connection is progressing in the background. - */ + if (connect(sock, (SOCKADDR *) &sockaddr, + sizeof(SOCKADDR_IN)) == SOCKET_ERROR) { + TclWinConvertWSAError((DWORD) WSAGetLastError()); + if (Tcl_GetErrno() != EWOULDBLOCK) { + goto error; + } - asyncConnect = 1; - } - goto connected; + /* + * The connection is progressing in the background. + */ - looperror: - if (sock != INVALID_SOCKET) { - closesocket(sock); - sock = INVALID_SOCKET; - } - } + asyncConnect = 1; } - goto error; - connected: /* * Add this socket to the global list of sockets. */ @@ -1357,33 +1066,22 @@ 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. */ - if (infoPtr != NULL) { - ioctlsocket(sock, (long) FIONBIO, &flag); - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, - (LPARAM) infoPtr); + 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_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't open socket: %s", - (errorMsg ? errorMsg : Tcl_PosixError(interp)))); + Tcl_AppendResult(interp, "couldn't open socket: ", + Tcl_PosixError(interp), NULL); } - if (sock != INVALID_SOCKET) { closesocket(sock); } @@ -1393,6 +1091,78 @@ 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. @@ -1415,7 +1185,8 @@ WaitForSocketEvent( { int result = 1; int oldMode; - ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) + TclThreadDataKeyGet(&dataKey); /* * Be sure to disable event servicing so we are truly modal. @@ -1429,6 +1200,7 @@ WaitForSocketEvent( SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT, (LPARAM) infoPtr); + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, (LPARAM) infoPtr); @@ -1440,7 +1212,7 @@ WaitForSocketEvent( } else if (infoPtr->readyEvents & events) { break; } else if (infoPtr->flags & SOCKET_ASYNC) { - *errorCodePtr = EAGAIN; + *errorCodePtr = EWOULDBLOCK; result = 0; break; } @@ -1499,18 +1271,19 @@ Tcl_OpenTcpClient( return NULL; } - sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t) infoPtr->sockets->fd); + sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t)infoPtr->socket); infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, - 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; + (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; } return infoPtr->channel; } @@ -1545,7 +1318,7 @@ Tcl_MakeTcpClientChannel( return NULL; } - tsdPtr = TclThreadDataKeyGet(&dataKey); + tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); /* * Set kernel space buffering and non-blocking. @@ -1560,11 +1333,12 @@ 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->sockets->fd); + sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t)infoPtr->socket); infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, - infoPtr, (TCL_READABLE | TCL_WRITABLE)); + (ClientData) infoPtr, (TCL_READABLE | TCL_WRITABLE)); Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto crlf"); return infoPtr->channel; } @@ -1615,14 +1389,14 @@ Tcl_OpenTcpServer( infoPtr->acceptProc = acceptProc; infoPtr->acceptProcData = acceptProcData; - sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t) infoPtr->sockets->fd); + sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t)infoPtr->socket); infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, - infoPtr, 0); + (ClientData) infoPtr, 0); if (Tcl_SetChannelOption(interp, infoPtr->channel, "-eofchar", "") == TCL_ERROR) { - Tcl_Close(NULL, infoPtr->channel); - return NULL; + Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel); + return (Tcl_Channel) NULL; } return infoPtr->channel; @@ -1633,9 +1407,8 @@ Tcl_OpenTcpServer( * * TcpAccept -- * - * Creates a channel for a newly accepted socket connection. This is - * called by SocketEventProc and it in turns calls the registered - * accept function. + * Accept a TCP socket connection. This is called by SocketEventProc and + * it in turns calls the registered accept function. * * Results: * None. @@ -1648,16 +1421,58 @@ Tcl_OpenTcpServer( static void TcpAccept( - TcpFdList *fds, /* Server socket that accepted newSocket. */ - SOCKET newSocket, /* Newly accepted socket. */ - address addr) /* Address of new socket. */ + SocketInfo *infoPtr) /* Socket to accept. */ { + SOCKET newSocket; SocketInfo *newInfoPtr; - SocketInfo *infoPtr = fds->infoPtr; - int len = sizeof(addr); + SOCKADDR_IN addr; + int len; char channelName[16 + TCL_INTEGER_SPACE]; - char host[NI_MAXHOST], port[NI_MAXSERV]; - ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + 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); /* * Win-NT has a misfeature that sockets are inherited in child processes @@ -1677,20 +1492,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->sockets->fd); + sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t)newInfoPtr->socket); newInfoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, - newInfoPtr, (TCL_READABLE | TCL_WRITABLE)); + (ClientData) newInfoPtr, (TCL_READABLE | TCL_WRITABLE)); if (Tcl_SetChannelOption(NULL, newInfoPtr->channel, "-translation", "auto crlf") == TCL_ERROR) { - Tcl_Close(NULL, newInfoPtr->channel); + Tcl_Close((Tcl_Interp *) NULL, newInfoPtr->channel); return; } if (Tcl_SetChannelOption(NULL, newInfoPtr->channel, "-eofchar", "") == TCL_ERROR) { - Tcl_Close(NULL, newInfoPtr->channel); + Tcl_Close((Tcl_Interp *) NULL, newInfoPtr->channel); return; } @@ -1699,10 +1514,8 @@ TcpAccept( */ if (infoPtr->acceptProc != NULL) { - getnameinfo(&(addr.sa), len, host, sizeof(host), port, sizeof(port), - NI_NUMERICHOST|NI_NUMERICSERV); - infoPtr->acceptProc(infoPtr->acceptProcData, newInfoPtr->channel, - host, atoi(port)); + (infoPtr->acceptProc) (infoPtr->acceptProcData, newInfoPtr->channel, + inet_ntoa(addr.sin_addr), ntohs(addr.sin_port)); } } @@ -1730,10 +1543,11 @@ TcpInputProc( int toRead, /* Maximum number of bytes to read. */ int *errorCodePtr) /* Where to store error codes. */ { - SocketInfo *infoPtr = instanceData; + SocketInfo *infoPtr = (SocketInfo *) instanceData; int bytesRead; DWORD error; - ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) + TclThreadDataKeyGet(&dataKey); *errorCodePtr = 0; @@ -1777,8 +1591,7 @@ TcpInputProc( while (1) { SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT, (LPARAM) infoPtr); - /* single fd operation: this proc is only called for a connected socket. */ - bytesRead = recv(infoPtr->sockets->fd, buf, toRead, 0); + bytesRead = recv(infoPtr->socket, buf, toRead, 0); infoPtr->readyEvents &= ~(FD_READ); /* @@ -1821,7 +1634,7 @@ TcpInputProc( */ if ((infoPtr->flags & SOCKET_ASYNC) || (error != WSAEWOULDBLOCK)) { - TclWinConvertError(error); + TclWinConvertWSAError(error); *errorCodePtr = Tcl_GetErrno(); bytesRead = -1; break; @@ -1838,7 +1651,8 @@ TcpInputProc( } } - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)infoPtr); + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, + (WPARAM) SELECT, (LPARAM) infoPtr); return bytesRead; } @@ -1867,10 +1681,11 @@ TcpOutputProc( int toWrite, /* Maximum number of bytes to write. */ int *errorCodePtr) /* Where to store error codes. */ { - SocketInfo *infoPtr = instanceData; + SocketInfo *infoPtr = (SocketInfo *) instanceData; int bytesWritten; DWORD error; - ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) + TclThreadDataKeyGet(&dataKey); *errorCodePtr = 0; @@ -1898,8 +1713,7 @@ TcpOutputProc( SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT, (LPARAM) infoPtr); - /* single fd operation: this proc is only called for a connected socket. */ - bytesWritten = send(infoPtr->sockets->fd, buf, toWrite, 0); + bytesWritten = send(infoPtr->socket, buf, toWrite, 0); if (bytesWritten != SOCKET_ERROR) { /* * Since Windows won't generate a new write event until we hit an @@ -1925,12 +1739,12 @@ TcpOutputProc( if (error == WSAEWOULDBLOCK) { infoPtr->readyEvents &= ~(FD_WRITE); if (infoPtr->flags & SOCKET_ASYNC) { - *errorCodePtr = EAGAIN; + *errorCodePtr = EWOULDBLOCK; bytesWritten = -1; break; } } else { - TclWinConvertError(error); + TclWinConvertWSAError(error); *errorCodePtr = Tcl_GetErrno(); bytesWritten = -1; break; @@ -1947,7 +1761,8 @@ TcpOutputProc( } } - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)infoPtr); + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, + (WPARAM) SELECT, (LPARAM) infoPtr); return bytesWritten; } @@ -1976,9 +1791,9 @@ TcpSetOptionProc( const char *value) /* New value for option. */ { #ifdef TCL_FEATURE_KEEPALIVE_NAGLE - SocketInfo *infoPtr = instanceData; + SocketInfo *infoPtr; SOCKET sock; -#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/ +#endif /* * Check that WinSock is initialized; do not call it if not, to prevent @@ -1988,15 +1803,14 @@ TcpSetOptionProc( if (!SocketsEnabled()) { if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "winsock is not initialized", -1)); + Tcl_AppendResult(interp, "winsock is not initialized", NULL); } return TCL_ERROR; } #ifdef TCL_FEATURE_KEEPALIVE_NAGLE - #error "TCL_FEATURE_KEEPALIVE_NAGLE not reviewed for whether to treat infoPtr->sockets as single fd or list" - sock = infoPtr->sockets->fd; + infoPtr = (SocketInfo *) instanceData; + sock = infoPtr->socket; if (!strcasecmp(optionName, "-keepalive")) { BOOL val = FALSE; @@ -2011,11 +1825,10 @@ TcpSetOptionProc( rtn = setsockopt(sock, SOL_SOCKET, SO_KEEPALIVE, (const char *) &val, sizeof(BOOL)); if (rtn != 0) { - TclWinConvertError(WSAGetLastError()); + TclWinConvertWSAError(WSAGetLastError()); if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't set socket option: %s", - Tcl_PosixError(interp))); + Tcl_AppendResult(interp, "couldn't set socket option: ", + Tcl_PosixError(interp), NULL); } return TCL_ERROR; } @@ -2033,11 +1846,10 @@ TcpSetOptionProc( rtn = setsockopt(sock, IPPROTO_TCP, TCP_NODELAY, (const char *) &val, sizeof(BOOL)); if (rtn != 0) { - TclWinConvertError(WSAGetLastError()); + TclWinConvertWSAError(WSAGetLastError()); if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't set socket option: %s", - Tcl_PosixError(interp))); + Tcl_AppendResult(interp, "couldn't set socket option: ", + Tcl_PosixError(interp), NULL); } return TCL_ERROR; } @@ -2080,12 +1892,14 @@ TcpGetOptionProc( Tcl_DString *dsPtr) /* Where to store the computed value; * initialized by caller. */ { - SocketInfo *infoPtr = instanceData; - char host[NI_MAXHOST], port[NI_MAXSERV]; + SocketInfo *infoPtr; + SOCKADDR_IN sockname; + SOCKADDR_IN peername; + struct hostent *hostEntPtr; SOCKET sock; + int size = sizeof(SOCKADDR_IN); size_t len = 0; - int reverseDNS = 0; -#define SUPPRESS_RDNS_VAR "::tcl::unsupported::noReverseDNS" + char buf[TCL_INTEGER_SPACE]; /* * Check that WinSock is initialized; do not call it if not, to prevent @@ -2095,13 +1909,13 @@ TcpGetOptionProc( if (!SocketsEnabled()) { if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "winsock is not initialized", -1)); + Tcl_AppendResult(interp, "winsock is not initialized", NULL); } return TCL_ERROR; } - sock = infoPtr->sockets->fd; + infoPtr = (SocketInfo *) instanceData; + sock = (int) infoPtr->socket; if (optionName != NULL) { len = strlen(optionName); } @@ -2113,40 +1927,40 @@ TcpGetOptionProc( int ret; optlen = sizeof(int); - ret = TclWinGetSockOpt(sock, SOL_SOCKET, SO_ERROR, + ret = TclWinGetSockOpt((int)sock, SOL_SOCKET, SO_ERROR, (char *)&err, &optlen); if (ret == SOCKET_ERROR) { err = WSAGetLastError(); } if (err) { - TclWinConvertError(err); + TclWinConvertWSAError(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))) { - address peername; - socklen_t size = sizeof(peername); - - if (getpeername(sock, (LPSOCKADDR) &(peername.sa), &size) == 0) { + if (getpeername(sock, (LPSOCKADDR) &peername, &size) == 0) { if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-peername"); Tcl_DStringStartSublist(dsPtr); } + Tcl_DStringAppendElement(dsPtr, inet_ntoa(peername.sin_addr)); - 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 (peername.sin_addr.s_addr == 0) { + hostEntPtr = NULL; + } else { + hostEntPtr = gethostbyaddr((char *) &(peername.sin_addr), + sizeof(peername.sin_addr), AF_INET); + } + if (hostEntPtr != NULL) { + Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name); + } else { + Tcl_DStringAppendElement(dsPtr, inet_ntoa(peername.sin_addr)); + } + TclFormatInt(buf, ntohs(peername.sin_port)); + Tcl_DStringAppendElement(dsPtr, buf); if (len == 0) { Tcl_DStringEndSublist(dsPtr); } else { @@ -2161,11 +1975,10 @@ TcpGetOptionProc( */ if (len) { - TclWinConvertError((DWORD) WSAGetLastError()); + TclWinConvertWSAError((DWORD) WSAGetLastError()); if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't get peername: %s", - Tcl_PosixError(interp))); + Tcl_AppendResult(interp, "can't get peername: ", + Tcl_PosixError(interp), NULL); } return TCL_ERROR; } @@ -2174,53 +1987,25 @@ TcpGetOptionProc( if ((len == 0) || ((len > 1) && (optionName[1] == 's') && (strncmp(optionName, "-sockname", len) == 0))) { - TcpFdList *fds; - address sockname; - socklen_t size; - int found = 0; - - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-sockname"); - Tcl_DStringStartSublist(dsPtr); - } - 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); + if (getsockname(sock, (LPSOCKADDR) &sockname, &size) == 0) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-sockname"); + Tcl_DStringStartSublist(dsPtr); } - } - if (found) { + Tcl_DStringAppendElement(dsPtr, inet_ntoa(sockname.sin_addr)); + if (sockname.sin_addr.s_addr == 0) { + hostEntPtr = NULL; + } else { + hostEntPtr = gethostbyaddr((char *) &(sockname.sin_addr), + sizeof(peername.sin_addr), AF_INET); + } + if (hostEntPtr != NULL) { + Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name); + } else { + Tcl_DStringAppendElement(dsPtr, inet_ntoa(sockname.sin_addr)); + } + TclFormatInt(buf, ntohs(sockname.sin_port)); + Tcl_DStringAppendElement(dsPtr, buf); if (len == 0) { Tcl_DStringEndSublist(dsPtr); } else { @@ -2228,9 +2013,9 @@ TcpGetOptionProc( } } else { if (interp) { - TclWinConvertError((DWORD) WSAGetLastError()); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't get sockname: %s", Tcl_PosixError(interp))); + TclWinConvertWSAError((DWORD) WSAGetLastError()); + Tcl_AppendResult(interp, "can't get sockname: ", + Tcl_PosixError(interp), NULL); } return TCL_ERROR; } @@ -2264,7 +2049,8 @@ 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 { @@ -2313,11 +2099,11 @@ TcpWatchProc( * TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ { - SocketInfo *infoPtr = instanceData; + SocketInfo *infoPtr = (SocketInfo *) instanceData; /* * Update the watch events mask. Only if the socket is not a server - * socket. [Bug 557878] + * socket. Fix for SF Tcl Bug #557878. */ if (!infoPtr->acceptProc) { @@ -2336,7 +2122,6 @@ TcpWatchProc( if (infoPtr->readyEvents & infoPtr->watchEvents) { Tcl_Time blockTime = { 0, 0 }; - Tcl_SetMaxBlockTime(&blockTime); } } @@ -2365,9 +2150,9 @@ TcpGetHandleProc( int direction, /* Not used. */ ClientData *handlePtr) /* Where to store the handle. */ { - SocketInfo *statePtr = instanceData; + SocketInfo *statePtr = (SocketInfo *) instanceData; - *handlePtr = INT2PTR(statePtr->sockets->fd); + *handlePtr = (ClientData) statePtr->socket; return TCL_OK; } @@ -2392,14 +2177,14 @@ SocketThread( LPVOID arg) { MSG msg; - ThreadSpecificData *tsdPtr = arg; + ThreadSpecificData *tsdPtr = (ThreadSpecificData *)(arg); /* * Create a dummy window receiving socket events. */ - tsdPtr->hwnd = CreateWindow(classname, classname, WS_TILED, 0, 0, 0, 0, - NULL, NULL, windowClass.hInstance, arg); + tsdPtr->hwnd = CreateWindow("TclSocket", "TclSocket", + WS_TILED, 0, 0, 0, 0, NULL, NULL, windowClass.hInstance, arg); /* * Signalize thread creator that we are done creating the window. @@ -2463,7 +2248,6 @@ SocketProc( int event, error; SOCKET socket; SocketInfo *infoPtr; - TcpFdList *fds = NULL; ThreadSpecificData *tsdPtr = (ThreadSpecificData *) #ifdef _WIN64 GetWindowLongPtr(hwnd, GWLP_USERDATA); @@ -2508,60 +2292,58 @@ SocketProc( WaitForSingleObject(tsdPtr->socketListLock, INFINITE); for (infoPtr = tsdPtr->socketList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { - for (fds = infoPtr->sockets; fds != NULL; fds = fds->next) { - if (fds->fd == 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 (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_CLOSE) { + infoPtr->acceptEventCount = 0; + infoPtr->readyEvents &= ~(FD_WRITE|FD_ACCEPT); + } else if (event & FD_ACCEPT) { + infoPtr->acceptEventCount++; + } - if (event & FD_CONNECT) { - /* - * The socket is now connected, clear the async connect - * flag. - */ + if (event & FD_CONNECT) { + /* + * The socket is now connected, clear the async connect + * flag. + */ - infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); + infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); - /* - * Remember any error that occurred so we can report - * connection failures. - */ + /* + * Remember any error that occurred so we can report + * connection failures. + */ - if (error != ERROR_SUCCESS) { - TclWinConvertError((DWORD) error); - infoPtr->lastError = Tcl_GetErrno(); - } + 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; + if (infoPtr->flags & SOCKET_ASYNC_CONNECT) { + infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); + if (error != ERROR_SUCCESS) { + TclWinConvertWSAError((DWORD) error); + infoPtr->lastError = Tcl_GetErrno(); } - infoPtr->readyEvents |= event; + infoPtr->readyEvents |= FD_WRITE; + } + 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); @@ -2569,18 +2351,15 @@ SocketProc( case SOCKET_SELECT: infoPtr = (SocketInfo *) lParam; - 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 - */ + if (wParam == SELECT) { + WSAAsyncSelect(infoPtr->socket, hwnd, + SOCKET_MESSAGE, infoPtr->selectEvents); + } else { + /* + * Clear the selection mask + */ - WSAAsyncSelect(fds->fd, hwnd, 0, 0); - } + WSAAsyncSelect(infoPtr->socket, hwnd, 0, 0); } break; @@ -2635,16 +2414,16 @@ InitializeHostName( int *lengthPtr, Tcl_Encoding *encodingPtr) { - TCHAR tbuf[MAX_COMPUTERNAME_LENGTH + 1]; - DWORD length = MAX_COMPUTERNAME_LENGTH + 1; + WCHAR wbuf[MAX_COMPUTERNAME_LENGTH + 1]; + DWORD length = sizeof(wbuf) / sizeof(WCHAR); Tcl_DString ds; - if (GetComputerName(tbuf, &length) != 0) { + if ((*tclWinProcs->getComputerNameProc)(wbuf, &length) != 0) { /* * Convert string from native to UTF then change to lowercase. */ - Tcl_UtfToLower(Tcl_WinTCharToUtf(tbuf, -1, &ds)); + Tcl_UtfToLower(Tcl_WinTCharToUtf((TCHAR *) wbuf, -1, &ds)); } else { Tcl_DStringInit(&ds); @@ -2669,7 +2448,7 @@ InitializeHostName( *encodingPtr = Tcl_GetEncoding(NULL, "utf-8"); *lengthPtr = Tcl_DStringLength(&ds); - *valuePtr = ckalloc((*lengthPtr) + 1); + *valuePtr = ckalloc((unsigned int) (*lengthPtr)+1); memcpy(*valuePtr, Tcl_DStringValue(&ds), (size_t)(*lengthPtr)+1); Tcl_DStringFree(&ds); } @@ -2694,12 +2473,8 @@ 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 @@ -2715,11 +2490,7 @@ TclWinGetSockOpt( } int -TclWinSetSockOpt( - SOCKET s, - int level, - int optname, - const char *optval, +TclWinSetSockOpt(SOCKET s, int level, int optname, const char *optval, int optlen) { /* @@ -2736,8 +2507,7 @@ TclWinSetSockOpt( } char * -TclpInetNtoa( - struct in_addr addr) +TclpInetNtoa(struct in_addr addr) { /* * Check that WinSock is initialized; do not call it if not, to prevent @@ -2792,7 +2562,7 @@ TcpThreadActionProc( int action) { ThreadSpecificData *tsdPtr; - SocketInfo *infoPtr = instanceData; + SocketInfo *infoPtr = (SocketInfo *) instanceData; int notifyCmd; if (action == TCL_CHANNEL_THREAD_INSERT) { diff --git a/win/tclWinTest.c b/win/tclWinTest.c index b83c0ba..e493fbf 100644 --- a/win/tclWinTest.c +++ b/win/tclWinTest.c @@ -9,9 +9,6 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#ifndef USE_TCL_STUBS -# define USE_TCL_STUBS -#endif #include "tclInt.h" /* @@ -32,6 +29,7 @@ * 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, @@ -186,7 +184,7 @@ TestvolumetypeCmd( #define VOL_BUF_SIZE 32 int found; char volType[VOL_BUF_SIZE]; - const char *path; + char *path; if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "?name?"); @@ -211,7 +209,7 @@ TestvolumetypeCmd( TclWinConvertError(GetLastError()); return TCL_ERROR; } - Tcl_AppendResult(interp, volType, NULL); + Tcl_SetResult(interp, volType, TCL_VOLATILE); return TCL_OK; #undef VOL_BUF_SIZE } @@ -341,7 +339,7 @@ TestExceptionCmd( int objc, /* Argument count */ Tcl_Obj *const objv[]) /* Argument vector */ { - static const char *const cmds[] = { + static const char *cmds[] = { "access_violation", "datatype_misalignment", "array_bounds", "float_denormal", "float_divbyzero", "float_inexact", "float_invalidop", "float_overflow", "float_stack", "float_underflow", @@ -398,6 +396,28 @@ 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 @@ -408,6 +428,22 @@ 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 = { @@ -419,14 +455,72 @@ TestplatformChmod( PACL curAcl, newAcl = 0; WORD j; SID *userSid = 0; - char *userDomain = 0; + TCHAR *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 = GetFileAttributesA(nativePath); + attr = GetFileAttributes(nativePath); /* * nativePath not found @@ -438,10 +532,11 @@ TestplatformChmod( } /* - * If nativePath is not a directory, there is no special handling. + * If no ACL API is present or nativePath is not a directory, there is no + * special handling. */ - if (!(attr & FILE_ATTRIBUTE_DIRECTORY)) { + if (initialized < 0 || !(attr & FILE_ATTRIBUTE_DIRECTORY)) { goto done; } @@ -457,15 +552,15 @@ TestplatformChmod( * obtains the size of the security descriptor. */ - if (!GetFileSecurityA(nativePath, infoBits, NULL, 0, &secDescLen)) { + if (!getFileSecurityProc(nativePath, infoBits, NULL, 0, &secDescLen)) { DWORD secDescLen2 = 0; if (GetLastError() != ERROR_INSUFFICIENT_BUFFER) { goto done; } - secDesc = ckalloc(secDescLen); - if (!GetFileSecurityA(nativePath, infoBits, + secDesc = (BYTE *) ckalloc(secDescLen); + if (!getFileSecurityProc(nativePath, infoBits, (PSECURITY_DESCRIPTOR) secDesc, secDescLen, &secDescLen2) || (secDescLen < secDescLen2)) { goto done; @@ -476,22 +571,22 @@ TestplatformChmod( * Get the World SID. */ - userSid = ckalloc(GetSidLengthRequired((UCHAR) 1)); - InitializeSid(userSid, &userSidAuthority, (BYTE) 1); - *(GetSidSubAuthority(userSid, 0)) = SECURITY_WORLD_RID; + userSid = (SID *) ckalloc(getSidLengthRequiredProc((UCHAR) 1)); + initializeSidProc(userSid, &userSidAuthority, (BYTE) 1); + *(getSidSubAuthorityProc(userSid, 0)) = SECURITY_WORLD_RID; /* * If curAclPresent == false then curAcl and curAclDefaulted not valid. */ - if (!GetSecurityDescriptorDacl((PSECURITY_DESCRIPTOR) secDesc, + if (!getSecurityDescriptorDaclProc((PSECURITY_DESCRIPTOR) secDesc, &curAclPresent, &curAcl, &curAclDefaulted)) { goto done; } if (!curAclPresent || !curAcl) { ACLSize.AclBytesInUse = 0; ACLSize.AceCount = 0; - } else if (!GetAclInformation(curAcl, &ACLSize, sizeof(ACLSize), + } else if (!getAclInformationProc(curAcl, &ACLSize, sizeof(ACLSize), AclSizeInformation)) { goto done; } @@ -501,14 +596,14 @@ TestplatformChmod( */ newAclSize = ACLSize.AclBytesInUse + sizeof(ACCESS_DENIED_ACE) - + GetLengthSid(userSid) - sizeof(DWORD); - newAcl = ckalloc(newAclSize); + + getLengthSidProc(userSid) - sizeof(DWORD); + newAcl = (ACL *) ckalloc(newAclSize); /* * Initialize the new ACL. */ - if (!InitializeAcl(newAcl, newAclSize, ACL_REVISION)) { + if (!initializeAclProc(newAcl, newAclSize, ACL_REVISION)) { goto done; } @@ -516,7 +611,7 @@ TestplatformChmod( * Add denied to make readonly, this will be known as a "read-only tag". */ - if (set_readOnly && !AddAccessDeniedAce(newAcl, ACL_REVISION, + if (set_readOnly && !addAccessDeniedAceProc(newAcl, ACL_REVISION, readOnlyMask, userSid)) { goto done; } @@ -526,7 +621,7 @@ TestplatformChmod( LPVOID pACE2; ACE_HEADER *phACE2; - if (!GetAce(curAcl, j, &pACE2)) { + if (!getAceProc(curAcl, j, &pACE2)) { goto done; } @@ -549,7 +644,7 @@ TestplatformChmod( ACCESS_DENIED_ACE *pACEd = (ACCESS_DENIED_ACE *) phACE2; if (pACEd->Mask == readOnlyMask - && EqualSid(userSid, (PSID) &pACEd->SidStart)) { + && equalSidProc(userSid, (PSID) &pACEd->SidStart)) { acl_readOnly_found = TRUE; continue; } @@ -559,7 +654,7 @@ TestplatformChmod( * Copy the current ACE from the old to the new ACL. */ - if (!AddAce(newAcl, ACL_REVISION, MAXDWORD, (PACL *) pACE2, + if (!addAceProc(newAcl, ACL_REVISION, MAXDWORD, (PACL *)pACE2, ((PACE_HEADER) pACE2)->AceSize)) { goto done; } @@ -569,7 +664,7 @@ TestplatformChmod( * Apply the new ACL. */ - if (set_readOnly == acl_readOnly_found || SetNamedSecurityInfoA( + if (set_readOnly == acl_readOnly_found || setNamedSecurityInfoProc( (LPSTR) nativePath, SE_FILE_OBJECT, DACL_SECURITY_INFORMATION, NULL, NULL, newAcl, NULL) == ERROR_SUCCESS) { res = 0; @@ -577,13 +672,13 @@ TestplatformChmod( done: if (secDesc) { - ckfree(secDesc); + ckfree((char *) secDesc); } if (newAcl) { - ckfree(newAcl); + ckfree((char *) newAcl); } if (userSid) { - ckfree(userSid); + ckfree((char *) userSid); } if (userDomain) { ckfree(userDomain); diff --git a/win/tclWinThrd.c b/win/tclWinThrd.c index 1c9d483..2413a78 100644 --- a/win/tclWinThrd.c +++ b/win/tclWinThrd.c @@ -5,7 +5,6 @@ * * 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. @@ -211,7 +210,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 @@ -335,7 +334,7 @@ TclpThreadExit( Tcl_ThreadId Tcl_GetCurrentThread(void) { - return (Tcl_ThreadId)(size_t)GetCurrentThreadId(); + return (Tcl_ThreadId) INT2PTR(GetCurrentThreadId()); } /* @@ -577,7 +576,7 @@ Tcl_MutexLock( */ if (*mutexPtr == NULL) { - csPtr = ckalloc(sizeof(CRITICAL_SECTION)); + csPtr = (CRITICAL_SECTION *) ckalloc(sizeof(CRITICAL_SECTION)); InitializeCriticalSection(csPtr); *mutexPtr = (Tcl_Mutex)csPtr; TclRememberMutex(mutexPtr); @@ -638,7 +637,7 @@ TclpFinalizeMutex( if (csPtr != NULL) { DeleteCriticalSection(csPtr); - ckfree(csPtr); + ckfree((char *) csPtr); *mutexPtr = NULL; } } @@ -669,7 +668,7 @@ void Tcl_ConditionWait( Tcl_Condition *condPtr, /* Really (WinCondition **) */ Tcl_Mutex *mutexPtr, /* Really (CRITICAL_SECTION **) */ - const Tcl_Time *timePtr) /* Timeout on waiting period */ + Tcl_Time *timePtr) /* Timeout on waiting period */ { WinCondition *winCondPtr; /* Per-condition queue head */ CRITICAL_SECTION *csPtr; /* Caller's Mutex, after casting */ @@ -708,7 +707,8 @@ Tcl_ConditionWait( * and initializing that may drop back into the Master Lock. */ - Tcl_CreateThreadExitHandler(FinalizeConditionEvent, tsdPtr); + Tcl_CreateThreadExitHandler(FinalizeConditionEvent, + (ClientData) tsdPtr); } } @@ -720,7 +720,7 @@ Tcl_ConditionWait( */ if (*condPtr == NULL) { - winCondPtr = ckalloc(sizeof(WinCondition)); + winCondPtr = (WinCondition *) ckalloc(sizeof(WinCondition)); InitializeCriticalSection(&winCondPtr->condLock); winCondPtr->firstPtr = NULL; winCondPtr->lastPtr = NULL; @@ -769,8 +769,7 @@ Tcl_ConditionWait( while (!timeout && (tsdPtr->flags & WIN_THREAD_BLOCKED)) { ResetEvent(tsdPtr->condEvent); LeaveCriticalSection(&winCondPtr->condLock); - if (WaitForSingleObjectEx(tsdPtr->condEvent, wtime, - TRUE) == WAIT_TIMEOUT) { + if (WaitForSingleObject(tsdPtr->condEvent, wtime) == WAIT_TIMEOUT) { timeout = 1; } EnterCriticalSection(&winCondPtr->condLock); @@ -931,7 +930,7 @@ TclpFinalizeCondition( if (winCondPtr != NULL) { DeleteCriticalSection(&winCondPtr->condLock); - ckfree(winCondPtr); + ckfree((char *) winCondPtr); *condPtr = NULL; } } @@ -974,7 +973,7 @@ TclpFreeAllocMutex( void * TclpGetAllocCache(void) { - void *result; + VOID *result; if (!once) { /* @@ -1039,61 +1038,6 @@ 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 new file mode 100644 index 0000000..41bc7aa --- /dev/null +++ b/win/tclWinThrd.h @@ -0,0 +1,19 @@ +/* + * 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 daa229d..0163723 100644 --- a/win/tclWinTime.c +++ b/win/tclWinTime.c @@ -87,7 +87,7 @@ typedef struct TimeInfo { } TimeInfo; static TimeInfo timeInfo = { - { NULL, 0, 0, NULL, NULL, 0 }, + { NULL }, 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,6 +200,35 @@ 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 @@ -223,7 +252,7 @@ void Tcl_GetTime( Tcl_Time *timePtr) /* Location to store time information. */ { - tclGetTimeProcPtr(timePtr, tclTimeClientData); + (*tclGetTimeProcPtr) (timePtr, tclTimeClientData); } /* @@ -280,7 +309,7 @@ NativeGetTime( Tcl_Time *timePtr, ClientData clientData) { - struct timeb t; + struct _timeb t; int useFtime = 1; /* Flag == TRUE if we need to fall back on * ftime rather than using the perf counter. */ @@ -385,7 +414,7 @@ NativeGetTime( WaitForSingleObject(timeInfo.readyEvent, INFINITE); CloseHandle(timeInfo.readyEvent); - Tcl_CreateExitHandler(StopCalibration, NULL); + Tcl_CreateExitHandler(StopCalibration, (ClientData) NULL); } timeInfo.initialized = TRUE; } @@ -446,7 +475,7 @@ NativeGetTime( * High resolution timer is not available. Just use ftime. */ - ftime(&t); + _ftime(&t); timePtr->sec = (long)t.time; timePtr->usec = t.millitm * 1000; } @@ -489,6 +518,93 @@ 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 @@ -506,7 +622,7 @@ StopCalibration( struct tm * TclpGetDate( - const time_t *t, + CONST time_t *t, int useGMT) { struct tm *tmPtr; @@ -1052,7 +1168,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 */ { /* @@ -1083,8 +1199,9 @@ 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 deleted file mode 100644 index 721825b..0000000 --- a/win/tclooConfig.sh +++ /dev/null @@ -1,19 +0,0 @@ -# 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 diff --git a/win/tclsh.ico b/win/tclsh.ico Binary files differindex e254318..8bcaf48 100644 --- a/win/tclsh.ico +++ b/win/tclsh.ico |