diff options
Diffstat (limited to 'win')
37 files changed, 5642 insertions, 6246 deletions
diff --git a/win/Makefile.in b/win/Makefile.in index 132721a..e9a28c4 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -81,12 +81,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. @@ -94,15 +89,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@ @@ -116,7 +111,6 @@ GENERIC_DIR_NATIVE = $(shell $(CYGPATH) '$(GENERIC_DIR)') TOMMATH_DIR_NATIVE = $(shell $(CYGPATH) '$(TOMMATH_DIR)') WIN_DIR_NATIVE = $(shell $(CYGPATH) '$(WIN_DIR)') ROOT_DIR_NATIVE = $(shell $(CYGPATH) '$(ROOT_DIR)') -ZLIB_DIR_NATIVE = $(shell $(CYGPATH) '$(ZLIB_DIR)') #GENERIC_DIR_NATIVE = $(GENERIC_DIR) #TOMMATH_DIR_NATIVE = $(TOMMATH_DIR) #WIN_DIR_NATIVE = $(WIN_DIR) @@ -124,7 +118,7 @@ ZLIB_DIR_NATIVE = $(shell $(CYGPATH) '$(ZLIB_DIR)') # Fully qualify library path so that `make test` # does not depend on the current directory. -LIBRARY_DIR1 = $(shell cd '$(ROOT_DIR_NATIVE)/library' ; pwd -P) +LIBRARY_DIR1 = $(shell cd '$(ROOT_DIR_NATIVE)/library' ; pwd) LIBRARY_DIR = $(shell $(CYGPATH) '$(LIBRARY_DIR1)') DLLSUFFIX = @DLLSUFFIX@ LIBSUFFIX = @LIBSUFFIX@ @@ -141,33 +135,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) $(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 -SHARED_LIBRARIES = $(TCL_DLL_FILE) @ZLIB_DLL_FILE@ -STATIC_LIBRARIES = $(TCL_LIB_FILE) +# 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@ @@ -185,10 +183,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@ $(shell $(CYGPATH) '@ZLIB_LIBS@') +LIBS = @LIBS@ RMDIR = rm -rf MKDIR = mkdir -p @@ -197,9 +195,9 @@ RM = rm -f COPY = cp CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${TCL_SHLIB_CFLAGS} \ --I"${ZLIB_DIR_NATIVE}" -I"${GENERIC_DIR_NATIVE}" -DTCL_TOMMATH \ --DMP_PREC=4 -I"${TOMMATH_DIR_NATIVE}" -I"${WIN_DIR_NATIVE}" \ -${AC_FLAGS} ${COMPILE_DEBUG_FLAGS} ${NO_DEPRECATED_FLAGS} +-I"${GENERIC_DIR_NATIVE}" -DTCL_TOMMATH -DMP_PREC=4 -I"${TOMMATH_DIR_NATIVE}" \ +-I"${WIN_DIR_NATIVE}" ${AC_FLAGS} \ +${COMPILE_DEBUG_FLAGS} ${NO_DEPRECATED_FLAGS} CC_OBJNAME = @CC_OBJNAME@ CC_EXENAME = @CC_EXENAME@ @@ -214,7 +212,8 @@ TCLTEST_OBJS = \ tclTestObj.$(OBJEXT) \ tclTestProcBodyObj.$(OBJEXT) \ tclThreadTest.$(OBJEXT) \ - tclWinTest.$(OBJEXT) + tclWinTest.$(OBJEXT) \ + testMain.$(OBJEXT) GENERIC_OBJS = \ regcomp.$(OBJEXT) \ @@ -222,7 +221,6 @@ GENERIC_OBJS = \ regfree.$(OBJEXT) \ regerror.$(OBJEXT) \ tclAlloc.$(OBJEXT) \ - tclAssembly.$(OBJEXT) \ tclAsync.$(OBJEXT) \ tclBasic.$(OBJEXT) \ tclBinary.$(OBJEXT) \ @@ -232,16 +230,12 @@ GENERIC_OBJS = \ tclCmdIL.$(OBJEXT) \ tclCmdMZ.$(OBJEXT) \ tclCompCmds.$(OBJEXT) \ - tclCompCmdsGR.$(OBJEXT) \ - tclCompCmdsSZ.$(OBJEXT) \ tclCompExpr.$(OBJEXT) \ tclCompile.$(OBJEXT) \ tclConfig.$(OBJEXT) \ tclDate.$(OBJEXT) \ tclDictObj.$(OBJEXT) \ - tclDisassemble.$(OBJEXT) \ tclEncoding.$(OBJEXT) \ - tclEnsemble.$(OBJEXT) \ tclEnv.$(OBJEXT) \ tclEvent.$(OBJEXT) \ tclExecute.$(OBJEXT) \ @@ -256,7 +250,6 @@ GENERIC_OBJS = \ tclIOCmd.$(OBJEXT) \ tclIOGT.$(OBJEXT) \ tclIORChan.$(OBJEXT) \ - tclIORTrans.$(OBJEXT) \ tclIOSock.$(OBJEXT) \ tclIOUtil.$(OBJEXT) \ tclLink.$(OBJEXT) \ @@ -264,18 +257,9 @@ GENERIC_OBJS = \ tclListObj.$(OBJEXT) \ tclLoad.$(OBJEXT) \ tclMain.$(OBJEXT) \ - tclMain2.$(OBJEXT) \ tclNamesp.$(OBJEXT) \ tclNotify.$(OBJEXT) \ - tclOO.$(OBJEXT) \ - tclOOBasic.$(OBJEXT) \ - tclOOCall.$(OBJEXT) \ - tclOODefineCmds.$(OBJEXT) \ - tclOOInfo.$(OBJEXT) \ - tclOOMethod.$(OBJEXT) \ - tclOOStubInit.$(OBJEXT) \ tclObj.$(OBJEXT) \ - tclOptimize.$(OBJEXT) \ tclPanic.$(OBJEXT) \ tclParse.$(OBJEXT) \ tclPathObj.$(OBJEXT) \ @@ -292,6 +276,7 @@ GENERIC_OBJS = \ tclStringObj.$(OBJEXT) \ tclStrToD.$(OBJEXT) \ tclStubInit.$(OBJEXT) \ + tclStubLib.$(OBJEXT) \ tclThread.$(OBJEXT) \ tclThreadAlloc.$(OBJEXT) \ tclThreadJoin.$(OBJEXT) \ @@ -301,8 +286,7 @@ GENERIC_OBJS = \ tclTrace.$(OBJEXT) \ tclUtf.$(OBJEXT) \ tclUtil.$(OBJEXT) \ - tclVar.$(OBJEXT) \ - tclZlib.$(OBJEXT) + tclVar.$(OBJEXT) TOMMATH_OBJS = \ bncore.${OBJEXT} \ @@ -387,46 +371,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@ @@ -444,33 +427,37 @@ ${TCL_STUB_LIB_FILE}: ${STUB_OBJS} @MAKE_STUB_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}: ${TCL_STUB_LIB_FILE} ${DDE_OBJS} +${DDE_DLL_FILE}: ${DDE_OBJS} ${TCL_STUB_LIB_FILE} + @$(RM) ${DDE_DLL_FILE} @MAKE_DLL@ ${DDE_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) -${REG_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${REG_OBJS} +${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}: ${TCL_STUB_LIB_FILE} ${TCLTEST_OBJS} - @$(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}/win32/zdll.libset" ; then \ - $(COPY) $(ZLIB_DIR)/win64/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \ - else \ - $(COPY) $(ZLIB_DIR)/win32/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \ - fi; +# 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. @@ -485,13 +472,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. # @@ -523,11 +528,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 @@ -553,11 +553,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)" ; \ @@ -569,7 +569,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"; \ @@ -577,14 +577,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)/"; \ @@ -593,27 +593,27 @@ install-binaries: binaries done @if [ -f $(DDE_DLL_FILE) ]; then \ echo Installing $(DDE_DLL_FILE); \ - $(COPY) $(DDE_DLL_FILE) $(LIB_INSTALL_DIR)/dde${DDEDOTVER}; \ + $(COPY) $(DDE_DLL_FILE) $(LIB_INSTALL_DIR)/dde$(DDEDOTVER); \ $(COPY) $(ROOT_DIR)/library/dde/pkgIndex.tcl \ - $(LIB_INSTALL_DIR)/dde${DDEDOTVER}; \ + $(LIB_INSTALL_DIR)/dde$(DDEDOTVER); \ fi @if [ -f $(DDE_LIB_FILE) ]; then \ echo Installing $(DDE_LIB_FILE); \ - $(COPY) $(DDE_LIB_FILE) $(LIB_INSTALL_DIR)/dde${DDEDOTVER}; \ + $(COPY) $(DDE_LIB_FILE) $(LIB_INSTALL_DIR)/dde$(DDEDOTVER); \ fi @if [ -f $(REG_DLL_FILE) ]; then \ echo Installing $(REG_DLL_FILE); \ - $(COPY) $(REG_DLL_FILE) $(LIB_INSTALL_DIR)/reg${REGDOTVER}; \ + $(COPY) $(REG_DLL_FILE) $(LIB_INSTALL_DIR)/reg$(REGDOTVER); \ $(COPY) $(ROOT_DIR)/library/reg/pkgIndex.tcl \ - $(LIB_INSTALL_DIR)/reg${REGDOTVER}; \ + $(LIB_INSTALL_DIR)/reg$(REGDOTVER); \ fi @if [ -f $(REG_LIB_FILE) ]; then \ echo Installing $(REG_LIB_FILE); \ - $(COPY) $(REG_LIB_FILE) $(LIB_INSTALL_DIR)/reg${REGDOTVER}; \ + $(COPY) $(REG_LIB_FILE) $(LIB_INSTALL_DIR)/reg$(REGDOTVER); \ fi install-libraries: libraries install-tzdata install-msgs - @for i in "$$($(CYGPATH) $(prefix)/lib)" "$(INCLUDE_INSTALL_DIR)" \ + @for i in $(prefix)/lib $(INCLUDE_INSTALL_DIR) \ $(SCRIPT_INSTALL_DIR); \ do \ if [ ! -d $$i ] ; then \ @@ -622,7 +622,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"; \ @@ -632,7 +632,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"; \ @@ -649,15 +648,15 @@ install-libraries: libraries install-tzdata install-msgs do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \ done; - @echo "Installing package http 2.8.9 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.8.9.tm; + @echo "Installing package http 2.7.13 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/http-2.7.13.tm; @echo "Installing library opt0.4 directory"; @for j in $(ROOT_DIR)/library/opt/*.tcl; \ do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ done; - @echo "Installing package msgcat 1.6.0 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.6.0.tm; + @echo "Installing package msgcat 1.5.2 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.5.2.tm; @echo "Installing package tcltest 2.3.8 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.8.tm; @echo "Installing package platform 1.0.14 as a Tcl Module"; @@ -671,12 +670,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 @@ -694,7 +695,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)"; \ @@ -704,21 +704,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.1 [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.1 [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` @@ -740,94 +736,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=`$(CYGPATH) $$(pwd -P)`; \ - for i in $(PKGS_DIR)/*; do \ - if [ -d $$i ] ; then \ - if [ -x $$i/configure ] ; then \ - pkg=`basename $$i`; \ - mkdir -p $(PKG_DIR)/$$pkg; \ - if [ ! -f $(PKG_DIR)/$$pkg/Makefile ]; then \ - ( cd $(PKG_DIR)/$$pkg; \ - echo "Configuring package '$$i' wd = `$(CYGPATH) $$(pwd -P)`"; \ - $$i/configure --with-tcl=$$builddir --with-tclinclude=$(GENERIC_DIR_NATIVE) $(PKG_CFG_ARGS) --enable-shared --enable-threads; ) \ - fi ; \ - echo "Building package '$$pkg'"; \ - ( cd $(PKG_DIR)/$$pkg; $(MAKE); ) \ - fi; \ - fi; \ - done; \ - cd $$builddir - -install-packages: packages - @builddir=`pwd -P`; \ - for i in $(PKGS_DIR)/*; do \ - if [ -d $$i ]; then \ - pkg=`basename $$i`; \ - if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \ - echo "Installing package '$$pkg'"; \ - ( cd $(PKG_DIR)/$$pkg; $(MAKE) install "DESTDIR=$(INSTALL_ROOT)"; ) \ - fi; \ - fi; \ - done; \ - cd $$builddir - -test-packages: tcltest packages - @builddir=`pwd -P`; \ - for i in $(PKGS_DIR)/*; do \ - if [ -d $$i ]; then \ - pkg=`basename $$i`; \ - if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \ - echo "Testing package '$$pkg'"; \ - ( cd $(PKG_DIR)/$$pkg; $(MAKE) "LD_LIBRARY_PATH=$$builddir:${LD_LIBRARY_PATH}" "TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" "TCLLIBPATH=$$builddir/pkgs" test "TCLSH_PROG=$$builddir/${TCLSH}"; ) \ - fi; \ - fi; \ - done; \ - cd $$builddir - -clean-packages: - @builddir=`pwd -P`; \ - for i in $(PKGS_DIR)/*; do \ - if [ -d $$i ]; then \ - pkg=`basename $$i`; \ - if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \ - ( cd $(PKG_DIR)/$$pkg; $(MAKE) clean; ) \ - fi; \ - fi; \ - done; \ - cd $$builddir - -distclean-packages: - @builddir=`pwd -P`; \ - for i in $(PKGS_DIR)/*; do \ - if [ -d $$i ]; then \ - pkg=`basename $$i`; \ - if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \ - ( cd $(PKG_DIR)/$$pkg; $(MAKE) distclean; ) \ - fi; \ - cd $$builddir; \ - rm -rf $(PKG_DIR)/$$pkg; \ - fi; \ - done; \ - rm -rf $(PKG_DIR) - -# # Regenerate the stubs files. # @@ -841,29 +759,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 @@ -79,9 +79,9 @@ Use the Makefile "install" target to install Tcl. It will install it according to the prefix options you provided in the correct directory structure. -Note that in order to run tclsh86.exe, you must ensure that tcl86.dll is +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 deb9e39..1a0f36d 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 4ce23f9..dc03e62 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_WIN_VERSION MACHINE TCL_VERSION TCL_MAJOR_VERSION TCL_MINOR_VERSION TCL_PATCH_LEVEL PKG_CFG_ARGS TCL_EXE TCL_LIB_FILE TCL_LIB_FLAG TCL_STATIC_LIB_FILE TCL_STATIC_LIB_FLAG TCL_IMPORT_LIB_FILE TCL_IMPORT_LIB_FLAG TCL_LIB_SPEC TCL_STUB_LIB_FILE TCL_STUB_LIB_FLAG TCL_STUB_LIB_SPEC TCL_STUB_LIB_PATH TCL_INCLUDE_SPEC TCL_BUILD_STUB_LIB_SPEC TCL_BUILD_STUB_LIB_PATH TCL_DLL_FILE TCL_SRC_DIR TCL_BIN_DIR TCL_DBGX CFG_TCL_SHARED_LIB_SUFFIX CFG_TCL_UNSHARED_LIB_SUFFIX CFG_TCL_EXPORT_FILE_SUFFIX EXTRA_CFLAGS DEPARG CC_OBJNAME CC_EXENAME LDFLAGS_DEBUG LDFLAGS_OPTIMIZE LDFLAGS_CONSOLE LDFLAGS_WINDOW STLIB_LD SHLIB_LD SHLIB_LD_LIBS SHLIB_CFLAGS SHLIB_SUFFIX TCL_SHARED_BUILD LIBS_GUI DLLSUFFIX LIBPREFIX LIBSUFFIX EXESUFFIX LIBRARIES MAKE_LIB MAKE_STUB_LIB POST_MAKE_LIB MAKE_DLL MAKE_EXE TCL_BUILD_LIB_SPEC TCL_LD_SEARCH_FLAGS TCL_NEEDS_EXP_FILE TCL_BUILD_EXP_FILE TCL_EXP_FILE TCL_LIB_VERSIONS_OK TCL_PACKAGE_PATH TCL_DDE_VERSION TCL_DDE_MAJOR_VERSION TCL_DDE_MINOR_VERSION TCL_REG_VERSION TCL_REG_MAJOR_VERSION TCL_REG_MINOR_VERSION RC_OUT RC_TYPE RC_INCLUDE RC_DEFINE RC_DEFINES RES LIBOBJS LTLIBOBJS' +ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS CC CFLAGS LDFLAGS CPPFLAGS ac_ct_CC EXEEXT OBJEXT CPP EGREP AR ac_ct_AR RANLIB ac_ct_RANLIB RC ac_ct_RC SET_MAKE TCL_THREADS CYGPATH CELIB_DIR DL_LIBS CFLAGS_DEBUG CFLAGS_OPTIMIZE CFLAGS_WARNING CFLAGS_DEFAULT LDFLAGS_DEFAULT VC_MANIFEST_EMBED_DLL VC_MANIFEST_EMBED_EXE TCL_WIN_VERSION MACHINE TCL_VERSION TCL_MAJOR_VERSION TCL_MINOR_VERSION TCL_PATCH_LEVEL TCL_LIB_FILE TCL_LIB_FLAG TCL_LIB_SPEC TCL_STUB_LIB_FILE TCL_STUB_LIB_FLAG TCL_STUB_LIB_SPEC TCL_STUB_LIB_PATH TCL_INCLUDE_SPEC TCL_BUILD_STUB_LIB_SPEC TCL_BUILD_STUB_LIB_PATH TCL_DLL_FILE TCL_SRC_DIR TCL_BIN_DIR TCL_DBGX CFG_TCL_SHARED_LIB_SUFFIX CFG_TCL_UNSHARED_LIB_SUFFIX CFG_TCL_EXPORT_FILE_SUFFIX EXTRA_CFLAGS DEPARG CC_OBJNAME CC_EXENAME LDFLAGS_DEBUG LDFLAGS_OPTIMIZE LDFLAGS_CONSOLE LDFLAGS_WINDOW STLIB_LD SHLIB_LD SHLIB_LD_LIBS SHLIB_CFLAGS SHLIB_SUFFIX TCL_SHARED_BUILD LIBS_GUI DLLSUFFIX LIBPREFIX LIBSUFFIX EXESUFFIX LIBRARIES MAKE_LIB MAKE_STUB_LIB POST_MAKE_LIB MAKE_DLL MAKE_EXE TCL_BUILD_LIB_SPEC TCL_LD_SEARCH_FLAGS TCL_NEEDS_EXP_FILE TCL_BUILD_EXP_FILE TCL_EXP_FILE TCL_LIB_VERSIONS_OK TCL_PACKAGE_PATH TCL_DDE_VERSION TCL_DDE_MAJOR_VERSION TCL_DDE_MINOR_VERSION TCL_REG_VERSION TCL_REG_MAJOR_VERSION TCL_REG_MINOR_VERSION RC_OUT RC_TYPE RC_INCLUDE RC_DEFINE RC_DEFINES RES LIBOBJS LTLIBOBJS' ac_subst_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=".4" +TCL_MINOR_VERSION=5 +TCL_PATCH_LEVEL=".18" 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 @@ -3340,7 +3328,7 @@ cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ - #ifndef _WIN32 + #ifndef __WIN32__ #error cross-compiler #endif @@ -3463,7 +3451,7 @@ cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ - #ifdef _WIN32 + #ifdef __WIN32__ #error win32 #endif @@ -3514,80 +3502,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 -luserenv -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' @@ -3607,6 +3529,9 @@ echo $ECHO_N "checking compiler flags... $ECHO_C" >&6 echo "$as_me:$LINENO: result: using static flags" >&5 echo "${ECHO_T}using static flags" >&6 runtime= + MAKE_DLL="echo " + LIBSUFFIX="s\${DBGX}.a" + LIBFLAGSUFFIX="s\${DBGX}" LIBRARIES="\${STATIC_LIBRARIES}" EXESUFFIX="s\${DBGX}.exe" else @@ -3624,29 +3549,29 @@ echo "$as_me: error: ${CC} does not support the -shared option. fi runtime= + # Link with gcc since ld does not link to default libs like + # -luser32 and -lmsvcrt by default. + SHLIB_LD='${CC} -shared' + SHLIB_LD_LIBS='${LIBS}' # Add SHLIB_LD_LIBS to the Make rule, not here. + MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -o \$@ ${extra_ldflags} \ + -Wl,--out-implib,\$(patsubst %.dll,lib%.a,\$@)" + LIBSUFFIX="\${DBGX}.a" + LIBFLAGSUFFIX="\${DBGX}" EXESUFFIX="\${DBGX}.exe" LIBRARIES="\${SHARED_LIBRARIES}" fi - # Link with gcc since ld does not link to default libs like - # -luser32 and -lmsvcrt by default. - SHLIB_LD='${CC} -shared' - SHLIB_LD_LIBS='${LIBS}' - MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -o \$@ ${extra_ldflags} \ - -Wl,--out-implib,\$(patsubst %.dll,lib%.a,\$@)" # DLLSUFFIX is separate because it is the building block for # users of tclConfig.sh that may build shared or static. DLLSUFFIX="\${DBGX}.dll" - LIBSUFFIX="\${DBGX}.a" - LIBFLAGSUFFIX="\${DBGX}" SHLIB_SUFFIX=.dll EXTRA_CFLAGS="${extra_cflags}" CFLAGS_DEBUG=-g CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer" - CFLAGS_WARNING="-Wall -Wdeclaration-after-statement" + CFLAGS_WARNING="-Wall" LDFLAGS_DEBUG= LDFLAGS_OPTIMIZE= @@ -3747,16 +3672,24 @@ 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}' case "x`echo \${VisualStudioVersion}`" in x1[4-9]*) lflags="${lflags} -nodefaultlib:libucrt.lib" @@ -3765,12 +3698,9 @@ echo "${ECHO_T}using shared flags" >&6 ;; esac fi - MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -out:\$@" # DLLSUFFIX is separate because it is the building block for # users of tclConfig.sh that may build shared or static. DLLSUFFIX="\${DBGX}.dll" - LIBSUFFIX="\${DBGX}.lib" - LIBFLAGSUFFIX="\${DBGX}" # This is a 2-stage check to make sure we have the 64-bit SDK # We have to know where the SDK is installed. @@ -3803,7 +3733,7 @@ echo "${ECHO_T} Using 64-bit $MACHINE mode" >&6 fi fi - LIBS="netapi32.lib kernel32.lib user32.lib advapi32.lib userenv.lib ws2_32.lib" + LIBS="user32.lib advapi32.lib ws2_32.lib" case "x`echo \${VisualStudioVersion}`" in x1[4-9]*) @@ -4010,7 +3940,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 @@ -4346,72 +4275,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 - - if test "$GCC" == "yes"; then - - ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64/libz.dll.a - - -else - - ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64/zdll.lib - - -fi - - -else - - ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win32/zdll.lib - - -fi - - -else - - ZLIB_OBJS=\${ZLIB_OBJS} - - -fi - - -cat >>confdefs.h <<\_ACEOF -#define HAVE_ZLIB 1 -_ACEOF - - echo "$as_me:$LINENO: checking for intptr_t" >&5 echo $ECHO_N "checking for intptr_t... $ECHO_C" >&6 if test "${ac_cv_type_intptr_t+set}" = set; then @@ -4683,7 +4546,6 @@ _ACEOF fi - #-------------------------------------------------------------------- # Perform additinal compiler tests. #-------------------------------------------------------------------- @@ -4761,217 +4623,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 @@ -5128,6 +4779,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}\"" @@ -5135,10 +4792,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}\"" @@ -5204,12 +4857,6 @@ TCL_WIN_VERSION="$TCL_VERSION.$TCL_RELEASE_LEVEL.`echo $TCL_PATCH_LEVEL | tr -d - - - - - - # empty on win @@ -5952,9 +5599,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 @@ -5965,14 +5609,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 9e9df90..6b30162 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=".4" +TCL_MINOR_VERSION=5 +TCL_PATCH_LEVEL=".18" 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,43 +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"], [ - AS_IF([test "$GCC" == "yes"],[ - AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64/libz.dll.a]) - ], [ - AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64/zdll.lib]) - ]) - ], [ - AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win32/zdll.lib]) - ]) -], [ - AC_SUBST(ZLIB_OBJS,[\${ZLIB_OBJS}]) -]) -AC_DEFINE(HAVE_ZLIB, 1, [Is there an installed zlib?]) - AC_CHECK_TYPE([intptr_t], [ AC_DEFINE([HAVE_INTPTR_T], 1, [Do we have the intptr_t type?])], [ AC_CACHE_CHECK([for pointer-size signed integer type], tcl_cv_intptr_t, [ @@ -173,7 +129,6 @@ AC_CHECK_TYPE([uintptr_t], [ type wide enough to hold a pointer.]) fi ]) - #-------------------------------------------------------------------- # Perform additinal compiler tests. #-------------------------------------------------------------------- @@ -201,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 @@ -294,6 +190,12 @@ eval "TCL_SRC_DIR=\"`cd $srcdir/..; $CYGPATH $(pwd)`\"" eval "TCL_DLL_FILE=tcl${VER}${DLLSUFFIX}" +eval "TCL_LIB_FILE=${LIBPREFIX}tcl$VER${LIBSUFFIX}" + +eval "TCL_LIB_FLAG=\"-ltcl${VER}${LIBFLAGSUFFIX}\"" +eval "TCL_BUILD_LIB_SPEC=\"-L`$CYGPATH $(pwd)` ${TCL_LIB_FLAG}\"" +eval "TCL_LIB_SPEC=\"-L${libdir} ${TCL_LIB_FLAG}\"" + eval "TCL_STUB_LIB_FILE=\"${LIBPREFIX}tclstub${VER}${LIBSUFFIX}\"" eval "TCL_STUB_LIB_FLAG=\"-ltclstub${VER}${LIBFLAGSUFFIX}\"" eval "TCL_BUILD_STUB_LIB_SPEC=\"-L`$CYGPATH $(pwd)` ${TCL_STUB_LIB_FLAG}\"" @@ -301,10 +203,6 @@ eval "TCL_STUB_LIB_SPEC=\"-L${libdir} ${TCL_STUB_LIB_FLAG}\"" eval "TCL_BUILD_STUB_LIB_PATH=\"`$CYGPATH $(pwd)`/${TCL_STUB_LIB_FILE}\"" eval "TCL_STUB_LIB_PATH=\"${libdir}/${TCL_STUB_LIB_FILE}\"" -eval "TCL_LIB_FILE=\"${LIBPREFIX}tcl${VER}${LIBSUFFIX}\"" -eval "TCL_BUILD_LIB_SPEC=\"-L`$CYGPATH $(pwd)` -ltcl${VER}${FLAGSUFFIX}\"" -eval "TCL_LIB_SPEC=\"-L${libdir} -ltcl${VER}${FLAGSUFFIX}\"" - # Install time header dir can be set via --includedir eval "TCL_INCLUDE_SPEC=\"-I${includedir}\"" @@ -367,15 +265,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 f5b5acc..6421682 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,16 +203,12 @@ TCLOBJS = \ $(TMPDIR)\tclCmdIL.obj \
$(TMPDIR)\tclCmdMZ.obj \
$(TMPDIR)\tclCompCmds.obj \
- $(TMPDIR)\tclCompCmdsGR.obj \
- $(TMPDIR)\tclCompCmdsSZ.obj \
$(TMPDIR)\tclCompExpr.obj \
$(TMPDIR)\tclCompile.obj \
$(TMPDIR)\tclConfig.obj \
$(TMPDIR)\tclDate.obj \
$(TMPDIR)\tclDictObj.obj \
- $(TMPDIR)\tclDisassemble.obj \
$(TMPDIR)\tclEncoding.obj \
- $(TMPDIR)\tclEnsemble.obj \
$(TMPDIR)\tclEnv.obj \
$(TMPDIR)\tclEvent.obj \
$(TMPDIR)\tclExecute.obj \
@@ -232,15 +231,7 @@ TCLOBJS = \ $(TMPDIR)\tclMain.obj \
$(TMPDIR)\tclNamesp.obj \
$(TMPDIR)\tclNotify.obj \
- $(TMPDIR)\tclOO.obj \
- $(TMPDIR)\tclOOBasic.obj \
- $(TMPDIR)\tclOOCall.obj \
- $(TMPDIR)\tclOODefineCmds.obj \
- $(TMPDIR)\tclOOInfo.obj \
- $(TMPDIR)\tclOOMethod.obj \
- $(TMPDIR)\tclOOStubInit.obj \
$(TMPDIR)\tclObj.obj \
- $(TMPDIR)\tclOptimize.obj \
$(TMPDIR)\tclPanic.obj \
$(TMPDIR)\tclParse.obj \
$(TMPDIR)\tclPipe.obj \
@@ -255,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 \
@@ -275,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
@@ -290,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
@@ -343,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)
@@ -392,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),, \
@@ -415,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)"
@@ -428,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"
@@ -455,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"
@@ -463,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)"
@@ -484,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
@@ -529,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
@@ -588,7 +595,3 @@ clean: -@$(RM) $(TMPDIR)\*.exe
-@$(RMDIR) $(OUTDIR)
-@$(RMDIR) $(TMPDIR)
-
-# Local Variables:
-# mode: makefile
-# End:
diff --git a/win/makefile.vc b/win/makefile.vc index 70f3f6e..267f53f 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -1,4 +1,4 @@ -#-------------------------------------------------------------
+#------------------------------------------------------------- -*- makefile -*-
# makefile.vc --
#
# Microsoft Visual C++ makefile for use with nmake.exe v1.62+ (VC++ 5.0+)
@@ -43,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,16 +263,12 @@ COREOBJS = \ $(TMP_DIR)\tclCmdIL.obj \
$(TMP_DIR)\tclCmdMZ.obj \
$(TMP_DIR)\tclCompCmds.obj \
- $(TMP_DIR)\tclCompCmdsGR.obj \
- $(TMP_DIR)\tclCompCmdsSZ.obj \
$(TMP_DIR)\tclCompExpr.obj \
$(TMP_DIR)\tclCompile.obj \
$(TMP_DIR)\tclConfig.obj \
$(TMP_DIR)\tclDate.obj \
$(TMP_DIR)\tclDictObj.obj \
- $(TMP_DIR)\tclDisassemble.obj \
$(TMP_DIR)\tclEncoding.obj \
- $(TMP_DIR)\tclEnsemble.obj \
$(TMP_DIR)\tclEnv.obj \
$(TMP_DIR)\tclEvent.obj \
$(TMP_DIR)\tclExecute.obj \
@@ -300,24 +285,14 @@ 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)\tclOptimize.obj \
$(TMP_DIR)\tclPanic.obj \
$(TMP_DIR)\tclParse.obj \
$(TMP_DIR)\tclPathObj.obj \
@@ -334,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 \
@@ -344,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 \
@@ -423,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
@@ -461,7 +412,6 @@ GENERICDIR = $(ROOT)\generic TOMMATHDIR = $(ROOT)\libtommath
TOOLSDIR = $(ROOT)\tools
WINDIR = $(ROOT)\win
-PKGSDIR = $(ROOT)\pkgs
#---------------------------------------------------------------------
# Compile flags
@@ -503,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)
@@ -550,7 +500,7 @@ dlllflags = $(lflags) -dll conlflags = $(lflags) -subsystem:console
guilflags = $(lflags) -subsystem:windows
-baselibs = netapi32.lib kernel32.lib user32.lib advapi32.lib userenv.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"
@@ -575,27 +525,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.1 [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.1 "$(TCLREGLIB:\=/)" registry]
+ package ifneeded dde 1.3.3 "$(TCLDDELIB:\=/)" dde]
+ package ifneeded registry 1.2.2 "$(TCLREGLIB:\=/)" registry]
<<
type tests.log | more
!endif
@@ -627,6 +577,7 @@ $** $**
<<
$(_VC_MANIFEST_EMBED_DLL)
+ -@del $*.exp
!endif
$(TCLSTUBLIB): $(TCLSTUBOBJS)
@@ -640,6 +591,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:$@ $**
@@ -648,6 +604,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)
@@ -658,40 +616,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 \
@@ -709,8 +637,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
@@ -926,10 +852,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$@ $?
@@ -939,9 +861,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:\=\\)\"" \
@@ -987,12 +906,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$@ $?
-
$(TMP_DIR)\tclsh.exe.manifest: $(WINDIR)\tclsh.exe.manifest.in
@nmakehlp -s << $** >$@
@MACHINE@ $(MACHINE:IX86=X86)
@@ -1034,9 +947,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::
@@ -1059,11 +970,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)" -i "$(TMP_DIR)" \
-d DEBUG=$(DEBUG) -d UNCHECKED=$(UNCHECKED) \
@@ -1092,6 +998,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)\"
@@ -1112,13 +1022,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)\"
@@ -1136,7 +1042,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\"
@@ -1145,7 +1050,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"
@@ -1216,7 +1121,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 ...
@@ -1237,7 +1142,3 @@ realclean: hose hose:
@echo Hosing $(OUT_DIR)\* ...
@if exist $(OUT_DIR)\nul $(RMDIR) $(OUT_DIR)
-
-# Local Variables:
-# mode: makefile
-# End:
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 d4c2f35..78a167a 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 96d5893..68920ad 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 a94cea6..8efff0b 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
@@ -247,7 +247,7 @@ AC_DEFUN([SC_PATH_TKCONFIG], [ # # Results: # -# Substitutes the following vars: +# Subst the following vars: # TCL_BIN_DIR # TCL_SRC_DIR # TCL_LIB_FILE @@ -401,11 +401,11 @@ AC_DEFUN([SC_ENABLE_SHARED], [ AC_DEFUN([SC_ENABLE_THREADS], [ AC_MSG_CHECKING(for building with threads) - AC_ARG_ENABLE(threads, [ --enable-threads build with threads (default: 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) ]) @@ -557,7 +557,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 -m, echo) @@ -572,7 +571,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ AC_CACHE_CHECK(for cross-compile version of gcc, ac_cv_cross, AC_TRY_COMPILE([ - #ifndef _WIN32 + #ifndef __WIN32__ #error cross-compiler #endif ], [], @@ -639,7 +638,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ AC_CACHE_CHECK(for mingw32 version of gcc, ac_cv_win32, AC_TRY_COMPILE([ - #ifdef _WIN32 + #ifdef __WIN32__ #error win32 #endif ], [], @@ -649,31 +648,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 -luserenv -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' @@ -692,6 +673,9 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ # static AC_MSG_RESULT([using static flags]) runtime= + MAKE_DLL="echo " + LIBSUFFIX="s\${DBGX}.a" + LIBFLAGSUFFIX="s\${DBGX}" LIBRARIES="\${STATIC_LIBRARIES}" EXESUFFIX="s\${DBGX}.exe" else @@ -705,29 +689,29 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ fi runtime= + # Link with gcc since ld does not link to default libs like + # -luser32 and -lmsvcrt by default. + SHLIB_LD='${CC} -shared' + SHLIB_LD_LIBS='${LIBS}' # Add SHLIB_LD_LIBS to the Make rule, not here. + MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -o \[$]@ ${extra_ldflags} \ + -Wl,--out-implib,\$(patsubst %.dll,lib%.a,\[$]@)" + LIBSUFFIX="\${DBGX}.a" + LIBFLAGSUFFIX="\${DBGX}" EXESUFFIX="\${DBGX}.exe" LIBRARIES="\${SHARED_LIBRARIES}" fi - # Link with gcc since ld does not link to default libs like - # -luser32 and -lmsvcrt by default. - SHLIB_LD='${CC} -shared' - SHLIB_LD_LIBS='${LIBS}' - MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -o \[$]@ ${extra_ldflags} \ - -Wl,--out-implib,\$(patsubst %.dll,lib%.a,\[$]@)" # DLLSUFFIX is separate because it is the building block for # users of tclConfig.sh that may build shared or static. DLLSUFFIX="\${DBGX}.dll" - LIBSUFFIX="\${DBGX}.a" - LIBFLAGSUFFIX="\${DBGX}" SHLIB_SUFFIX=.dll EXTRA_CFLAGS="${extra_cflags}" CFLAGS_DEBUG=-g CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer" - CFLAGS_WARNING="-Wall -Wdeclaration-after-statement" + CFLAGS_WARNING="-Wall" LDFLAGS_DEBUG= LDFLAGS_OPTIMIZE= @@ -782,15 +766,23 @@ 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}' case "x`echo \${VisualStudioVersion}`" in x1[[4-9]]*) lflags="${lflags} -nodefaultlib:libucrt.lib" @@ -799,12 +791,9 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ ;; esac fi - MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -out:\[$]@" # DLLSUFFIX is separate because it is the building block for # users of tclConfig.sh that may build shared or static. DLLSUFFIX="\${DBGX}.dll" - LIBSUFFIX="\${DBGX}.lib" - LIBFLAGSUFFIX="\${DBGX}" # This is a 2-stage check to make sure we have the 64-bit SDK # We have to know where the SDK is installed. @@ -834,7 +823,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ fi fi - LIBS="netapi32.lib kernel32.lib user32.lib advapi32.lib userenv.lib ws2_32.lib" + LIBS="user32.lib advapi32.lib ws2_32.lib" case "x`echo \${VisualStudioVersion}`" in x1[[4-9]]*) @@ -968,7 +957,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 @@ -1129,13 +1117,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 e06eaf5..251a610 100644 --- a/win/tclAppInit.c +++ b/win/tclAppInit.c @@ -2,67 +2,31 @@ * 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 -#define STRICT /* See MSDN Article Q83456 */ #include <windows.h> -#undef STRICT -#undef WIN32_LEAN_AND_MEAN #include <locale.h> -#include <stdlib.h> -#include <tchar.h> #ifdef TCL_TEST -extern Tcl_PackageInitProc 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 +#if defined(__GNUC__) int _CRT_glob = 0; -static void setargv(int *argcPtr, TCHAR ***argvPtr); -#endif /* TCL_BROKEN_MAINARGS */ - -/* - * The following #if block allows you to change the AppInit function by using - * a #define of TCL_LOCAL_APPINIT instead of rewriting this entire file. The - * #if checks for that #define and uses Tcl_AppInit if it does not exist. - */ - -#ifndef TCL_LOCAL_APPINIT -#define TCL_LOCAL_APPINIT Tcl_AppInit -#endif -#ifndef MODULE_SCOPE -# define MODULE_SCOPE extern -#endif -MODULE_SCOPE int TCL_LOCAL_APPINIT(Tcl_Interp *); - -/* - * The following #if block allows you to change how Tcl finds the startup - * script, prime the library or encoding paths, fiddle with the argv, etc., - * without needing to rewrite Tcl_Main() - */ - -#ifdef TCL_LOCAL_MAIN_HOOK -MODULE_SCOPE int TCL_LOCAL_MAIN_HOOK(int *argc, TCHAR ***argv); -#endif +static void setargv(int *argcPtr, char ***argvPtr); +#endif /* __GNUC__ */ /* *---------------------------------------------------------------------- @@ -72,45 +36,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, /* Number of command-line arguments. */ - char *dummy[]) /* Not used. */ -{ - TCHAR **argv; -#else -int -_tmain( - int argc, /* Number of command-line arguments. */ - TCHAR *argv[]) /* Values of command-line arguments. */ + int argc, + 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 command line. + * 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. @@ -127,6 +99,7 @@ _tmain( #endif Tcl_Main(argc, argv, TCL_LOCAL_APPINIT); + return 0; /* Needed only to prevent compiler warning. */ } @@ -135,9 +108,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 @@ -153,44 +126,57 @@ 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. */ /* @@ -200,8 +186,7 @@ Tcl_AppInit( * 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; } @@ -232,17 +217,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 @@ -261,15 +246,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; @@ -327,7 +307,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 688fa8d..e5e5202 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 @@ -33,14 +54,150 @@ static int platformId; /* Running under NT, or 95/98? */ #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 @@ -49,8 +206,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 @@ -69,7 +226,9 @@ TCL_DECLARE_MUTEX(mountPointMap) * We will need this below. */ -#ifdef _WIN32 +extern Tcl_FSDupInternalRepProc TclNativeDupInternalRep; + +#ifdef __WIN32__ #ifndef STATIC_BUILD /* @@ -111,7 +270,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." * *---------------------------------------------------------------------- */ @@ -122,22 +284,111 @@ DllMain( DWORD reason, /* Reason this function is being called. */ LPVOID reserved) /* Not used. */ { +#if defined(HAVE_NO_SEH) && !defined(_WIN64) + TCLEXCEPTION_REGISTRATION registration; +#endif + switch (reason) { case DLL_PROCESS_ATTACH: DisableThreadLibraryCalls(hInst); TclWinInit(hInst); return TRUE; + case DLL_PROCESS_DETACH: /* - * 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 TCLEXCEPTION_REGISTRATION to protect the call to + * Tcl_Finalize + */ + + "leal %[registration], %%edx" "\n\t" + "movl %%fs:0, %%eax" "\n\t" + "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ + "leal 1f, %%eax" "\n\t" + "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ + "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ + "movl %%esp, 0xc(%%edx)" "\n\t" /* esp */ + "movl %[error], 0x10(%%edx)" "\n\t" /* status */ + + /* + * Link the TCLEXCEPTION_REGISTRATION on the chain + */ + + "movl %%edx, %%fs:0" "\n\t" + + /* + * Call Tcl_Finalize + */ + + "call _Tcl_Finalize" "\n\t" + + /* + * Come here on a normal exit. Recover the TCLEXCEPTION_REGISTRATION + * and store a TCL_OK status + */ + + "movl %%fs:0, %%edx" "\n\t" + "movl %[ok], %%eax" "\n\t" + "movl %%eax, 0x10(%%edx)" "\n\t" + "jmp 2f" "\n" + + /* + * Come here on an exception. Get the TCLEXCEPTION_REGISTRATION that + * we previously put on the chain. + */ + + "1:" "\t" + "movl %%fs:0, %%edx" "\n\t" + "movl 0x8(%%edx), %%edx" "\n" + + + /* + * Come here however we exited. Restore context from the + * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. + */ + + "2:" "\t" + "movl 0xc(%%edx), %%esp" "\n\t" + "movl 0x8(%%edx), %%ebp" "\n\t" + "movl 0x0(%%edx), %%eax" "\n\t" + "movl %%eax, %%fs:0" "\n\t" + + : + /* No outputs */ + : + [registration] "m" (registration), + [ok] "i" (TCL_OK), + [error] "i" (TCL_ERROR) + : + "%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "memory" + ); + +#else +#ifndef HAVE_NO_SEH + __try { +#endif + Tcl_Finalize(); +#ifndef HAVE_NO_SEH + } __except (EXCEPTION_EXECUTE_HANDLER) { + /* empty handler body. */ + } +#endif +#endif + + break; } return TRUE; } #endif /* !STATIC_BUILD */ -#endif /* _WIN32 */ +#endif /* __WIN32__ */ /* *---------------------------------------------------------------------- @@ -189,18 +440,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; } /* @@ -213,10 +461,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. @@ -262,11 +509,95 @@ 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 + + +/* *--------------------------------------------------------------------------- * - * TclpSetInterfaces -- + * TclWinSetInterfaces -- + * + * A helper proc that allows the test library to change the tclWinProcs + * structure to dispatch to either the wide-character or multi-byte + * versions of the operating system calls, depending on whether Unicode + * is the system encoding. * - * A helper proc that initializes winTCharEncoding. + * As well as this, we can also try to load in some additional procs + * which may/may not be present depending on the current Windows version + * (e.g. Win95 will not have the procs below). * * Results: * None. @@ -278,18 +609,115 @@ TclWinNoBackslash( */ void -TclpSetInterfaces(void) +TclWinSetInterfaces( + int wide) /* Non-zero to use wide interfaces, 0 + * otherwise. */ { - TclWinResetInterfaces(); - winTCharEncoding = Tcl_GetEncoding(NULL, "unicode"); + Tcl_FreeEncoding(tclWinTCharEncoding); + + if (wide) { + tclWinProcs = &unicodeProcs; + tclWinTCharEncoding = Tcl_GetEncoding(NULL, "unicode"); + if (tclWinProcs->getFileAttributesExProc == NULL) { + HINSTANCE hInstance = LoadLibraryA("kernel32"); + if (hInstance != NULL) { + tclWinProcs->getFileAttributesExProc = + (BOOL (WINAPI *)(CONST TCHAR *, GET_FILEEX_INFO_LEVELS, + LPVOID)) GetProcAddress(hInstance, + "GetFileAttributesExW"); + tclWinProcs->createHardLinkProc = + (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR*, + LPSECURITY_ATTRIBUTES)) GetProcAddress(hInstance, + "CreateHardLinkW"); + tclWinProcs->findFirstFileExProc = + (HANDLE (WINAPI *)(CONST TCHAR*, UINT, LPVOID, UINT, + LPVOID, DWORD)) GetProcAddress(hInstance, + "FindFirstFileExW"); + tclWinProcs->getVolumeNameForVMPProc = + (BOOL (WINAPI *)(CONST TCHAR*, TCHAR*, + DWORD)) GetProcAddress(hInstance, + "GetVolumeNameForVolumeMountPointW"); + tclWinProcs->getLongPathNameProc = + (DWORD (WINAPI *)(CONST TCHAR*, TCHAR*, + DWORD)) GetProcAddress(hInstance, "GetLongPathNameW"); + FreeLibrary(hInstance); + } + hInstance = LoadLibraryA("advapi32"); + if (hInstance != NULL) { + tclWinProcs->getFileSecurityProc = (BOOL (WINAPI *)( + LPCTSTR lpFileName, + SECURITY_INFORMATION RequestedInformation, + PSECURITY_DESCRIPTOR pSecurityDescriptor, + DWORD nLength, LPDWORD lpnLengthNeeded)) + GetProcAddress(hInstance, "GetFileSecurityW"); + tclWinProcs->impersonateSelfProc = (BOOL (WINAPI *) ( + SECURITY_IMPERSONATION_LEVEL ImpersonationLevel)) + GetProcAddress(hInstance, "ImpersonateSelf"); + tclWinProcs->openThreadTokenProc = (BOOL (WINAPI *) ( + HANDLE ThreadHandle, DWORD DesiredAccess, + BOOL OpenAsSelf, PHANDLE TokenHandle)) + GetProcAddress(hInstance, "OpenThreadToken"); + tclWinProcs->revertToSelfProc = (BOOL (WINAPI *) (void)) + GetProcAddress(hInstance, "RevertToSelf"); + tclWinProcs->mapGenericMaskProc = (VOID (WINAPI *) ( + PDWORD AccessMask, PGENERIC_MAPPING GenericMapping)) + GetProcAddress(hInstance, "MapGenericMask"); + tclWinProcs->accessCheckProc = (BOOL (WINAPI *)( + PSECURITY_DESCRIPTOR pSecurityDescriptor, + HANDLE ClientToken, DWORD DesiredAccess, + PGENERIC_MAPPING GenericMapping, + PPRIVILEGE_SET PrivilegeSet, + LPDWORD PrivilegeSetLength, LPDWORD GrantedAccess, + LPBOOL AccessStatus)) GetProcAddress(hInstance, + "AccessCheck"); + FreeLibrary(hInstance); + } + } + } else { + tclWinProcs = &asciiProcs; + tclWinTCharEncoding = NULL; + if (tclWinProcs->getFileAttributesExProc == NULL) { + HINSTANCE hInstance = LoadLibraryA("kernel32"); + if (hInstance != NULL) { + tclWinProcs->getFileAttributesExProc = + (BOOL (WINAPI *)(CONST TCHAR *, GET_FILEEX_INFO_LEVELS, + LPVOID)) GetProcAddress(hInstance, + "GetFileAttributesExA"); + tclWinProcs->createHardLinkProc = + (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR*, + LPSECURITY_ATTRIBUTES)) GetProcAddress(hInstance, + "CreateHardLinkA"); + tclWinProcs->findFirstFileExProc = NULL; + tclWinProcs->getLongPathNameProc = NULL; + /* + * The 'findFirstFileExProc' function exists on some of + * 95/98/ME, but it seems not to work as anticipated. + * Therefore we don't set this function pointer. The relevant + * code will fall back on a slower approach using the normal + * findFirstFileProc. + * + * (HANDLE (WINAPI *)(CONST TCHAR*, UINT, + * LPVOID, UINT, LPVOID, DWORD)) GetProcAddress(hInstance, + * "FindFirstFileExA"); + */ + tclWinProcs->getVolumeNameForVMPProc = + (BOOL (WINAPI *)(CONST TCHAR*, TCHAR*, + DWORD)) GetProcAddress(hInstance, + "GetVolumeNameForVolumeMountPointA"); + FreeLibrary(hInstance); + } + } + } } /* *--------------------------------------------------------------------------- * - * TclWinEncodingsCleanup -- + * TclWinResetInterfaceEncodings -- * - * Called during finalization to free up any encodings we use. + * Called during finalization to free up any encodings we use. The + * tclWinProcs-> look up table is still ok to use after this call, + * provided no encoding conversion is required. * * We also clean up any memory allocated in our mount point map which is * used to follow certain kinds of symlinks. That code should never be @@ -305,11 +733,13 @@ TclpSetInterfaces(void) */ void -TclWinEncodingsCleanup(void) +TclWinResetInterfaceEncodings(void) { MountPointMap *dlIter, *dlIter2; - - TclWinResetInterfaces(); + if (tclWinTCharEncoding != NULL) { + Tcl_FreeEncoding(tclWinTCharEncoding); + tclWinTCharEncoding = NULL; + } /* * Clean up the mount point map. @@ -319,8 +749,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); @@ -332,6 +762,8 @@ TclWinEncodingsCleanup(void) * TclWinResetInterfaces -- * * Called during finalization to reset us to a safe state for reuse. + * After this call, it is best not to use the tclWinProcs-> look up table + * since it is likely to be different to what is expected. * * Results: * None. @@ -344,10 +776,7 @@ TclWinEncodingsCleanup(void) void TclWinResetInterfaces(void) { - if (winTCharEncoding != NULL) { - Tcl_FreeEncoding(winTCharEncoding); - winTCharEncoding = NULL; - } + tclWinProcs = &asciiProcs; } /* @@ -374,11 +803,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 @@ -389,28 +818,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; } } @@ -437,8 +866,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 @@ -461,23 +890,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; } } } @@ -488,9 +917,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; } } @@ -499,11 +928,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; } @@ -560,27 +989,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); } /* @@ -608,16 +1037,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 cca0dab..a271919 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 int NativeIsComPort(CONST TCHAR *nativeName); * 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. */ }; /* @@ -257,7 +257,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); @@ -340,7 +340,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, @@ -378,7 +378,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; @@ -424,7 +424,7 @@ FileCloseProc( break; } } - ckfree(fileInfoPtr); + ckfree((char *)fileInfoPtr); return errorCode; } @@ -453,7 +453,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; @@ -531,7 +531,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; @@ -580,7 +580,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; /* @@ -656,16 +656,13 @@ 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; /* - * TODO: This comment appears to be out of date. We *do* have a - * console driver, over in tclWinConsole.c. After some Windows - * developer confirms, this comment should be revised. - * * Note that we will block on reads from a console buffer until a full * line has been entered. The only way I know of to get around this is to * write a console driver. We should probably do this at some point, but @@ -707,11 +704,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; @@ -758,7 +755,7 @@ FileWatchProc( * of TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ { - FileInfo *infoPtr = instanceData; + FileInfo *infoPtr = (FileInfo *) instanceData; Tcl_Time blockTime = { 0, 0 }; /* @@ -796,7 +793,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; @@ -836,12 +833,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) { if (interp != (Tcl_Interp *) NULL) { Tcl_AppendResult(interp, "couldn't open \"", @@ -932,7 +929,7 @@ TclpOpenFileChannel( flags = FILE_ATTRIBUTE_READONLY; } } else { - flags = GetFileAttributes(nativeName); + flags = (*tclWinProcs->getFileAttributesProc)(nativeName); if (flags == 0xFFFFFFFF) { flags = 0; } @@ -948,8 +945,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(); @@ -959,9 +956,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; } @@ -971,7 +967,7 @@ TclpOpenFileChannel( switch (FileGetType(handle)) { case FILE_TYPE_SERIAL: /* - * Natively named serial ports "com1-9", "\\\\.\\comXX" are + * Natively named serial ports "com1-9", "\\\\.\\comXX" are * already done with the code above. * Here we handle all other serial port names. * @@ -983,9 +979,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; } @@ -1019,11 +1015,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; } @@ -1249,8 +1242,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) { @@ -1349,7 +1342,7 @@ TclWinOpenFileChannel( } } - infoPtr = ckalloc(sizeof(FileInfo)); + infoPtr = (FileInfo *) ckalloc((unsigned) sizeof(FileInfo)); /* * TIP #218. Removed the code inserting the new structure into the global @@ -1363,10 +1356,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 @@ -1440,7 +1433,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; @@ -1525,11 +1518,12 @@ FileGetType( * NativeIsComPort -- * * Determines if a path refers to a Windows serial port. - * A simple and efficient solution is to use a "name hint" to detect - * COM ports by their filename instead of resorting to a syscall + * A simple and efficient solution is to use a "name hint" to detect + * COM ports by their filename instead of resorting to a syscall * to detect serialness after the fact. * The following patterns cover common serial port names: - * COM[1-9] + * COM[1-9]:? + * //./COM[0-9]+ * \\.\COM[0-9]+ * * Results: @@ -1542,39 +1536,94 @@ static int NativeIsComPort( const TCHAR *nativePath) /* Path of file to access, native encoding. */ { - const WCHAR *p = (const WCHAR *) nativePath; - int i, len = wcslen(p); - /* - * 1. Look for com[1-9]:? + * Use wide-char or plain character case-insensitive comparison */ + if (tclWinProcs->useWide) { + const WCHAR *p = (const WCHAR *) nativePath; + int i, len = wcslen(p); - if ( (len == 4) && (_wcsnicmp(p, L"com", 3) == 0) ) { /* - * The 4th character must be a digit 1..9 - */ + * 1. Look for com[1-9]:? + */ + + if ( (len >= 4) && (len <= 5) + && (_wcsnicmp(p, L"com", 3) == 0) ) { + /* + * The 4th character must be a digit 1..9 optionally followed by a ":" + */ - if ( (p[3] < L'1') || (p[3] > L'9') ) { - return 0; + if ( (p[3] < L'1') || (p[3] > L'9') ) { + return 0; + } + if ( (len == 5) && (p[4] != L':') ) { + return 0; + } + return 1; } - return 1; - } - /* - * 2. Look for \\.\com[0-9]+ - */ + /* + * 2. Look for //./com[0-9]+ or \\.\com[0-9]+ + */ + + if ( (len >= 8) && ( + (_wcsnicmp(p, L"//./com", 7) == 0) + || (_wcsnicmp(p, L"\\\\.\\com", 7) == 0) ) ) + { + /* + * Charaters 8..end must be a digits 0..9 + */ + + for ( i=7; i<len; i++ ) { + if ( (p[i] < '0') || (p[i] > '9') ) { + return 0; + } + } + return 1; + } + + } else { + const char *p = (const char *) nativePath; + int i, len = strlen(p); - if ((len >= 8) && (_wcsnicmp(p, L"\\\\.\\com", 7) == 0)) { /* - * Charaters 8..end must be a digits 0..9 - */ + * 1. Look for com[1-9]:? + */ - for ( i=7; i<len; i++ ) { - if ( (p[i] < '0') || (p[i] > '9') ) { + if ( (len >= 4) && (len <= 5) + && (strnicmp(p, "com", 3) == 0) ) { + /* + * The 4th character must be a digit 1..9 optionally followed by a ":" + */ + + if ( (p[3] < '1') || (p[3] > '9') ) { return 0; } + if ( (len == 5) && (p[4] != ':') ) { + return 0; + } + return 1; + } + + /* + * 2. Look for //./com[0-9]+ or \\.\com[0-9]+ + */ + + if ( (len >= 8) && ( + (strnicmp(p, "//./com", 7) == 0) + || (strnicmp(p, "\\\\.\\com", 7) == 0) ) ) + { + /* + * Charaters 8..end must be a digits 0..9 + */ + + for ( i=7; i<len; i++ ) { + if ( (p[i] < '0') || (p[i] > '9') ) { + return 0; + } + } + return 1; } - return 1; } return 0; } diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index ab55035..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,44 +196,30 @@ ReadConsoleBytes( { DWORD ntchars; BOOL result; - int tcharsize = sizeof(TCHAR); - - /* - * If user types a Ctrl-Break or Ctrl-C, ReadConsole will return - * success with ntchars == 0 and GetLastError() will be - * ERROR_OPERATION_ABORTED. We do not want to treat this case - * as EOF so we will loop around again. If no Ctrl signal handlers - * have been established, the default signal OS handler in a separate - * thread will terminate the program. If a Ctrl signal handler - * has been established (through an extension for example), it - * will run and take whatever action it deems appropriate. - */ - do { - result = ReadConsole(hConsole, lpBuffer, nbytes / tcharsize, &ntchars, - NULL); - } while (result && ntchars == 0 && GetLastError() == ERROR_OPERATION_ABORTED); - if (nbytesread != NULL) { - *nbytesread = ntchars * tcharsize; - } + 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; } @@ -278,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. @@ -292,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); @@ -320,7 +286,7 @@ ConsoleInit(void) static void ConsoleExitHandler( - ClientData clientData) /* Old window proc. */ + ClientData clientData) /* Old window proc */ { Tcl_DeleteEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL); } @@ -344,7 +310,7 @@ ConsoleExitHandler( static void ProcExitHandler( - ClientData clientData) /* Old window proc. */ + ClientData clientData) /* Old window proc */ { Tcl_MutexLock(&consoleMutex); initialized = 0; @@ -389,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; } } @@ -428,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); @@ -452,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; } } @@ -465,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); @@ -475,6 +439,7 @@ ConsoleCheckProc( } } + /* *---------------------------------------------------------------------- * @@ -497,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 @@ -510,7 +475,7 @@ ConsoleBlockModeProc( if (mode == TCL_MODE_NONBLOCKING) { infoPtr->flags |= CONSOLE_ASYNC; } else { - infoPtr->flags &= ~CONSOLE_ASYNC; + infoPtr->flags &= ~(CONSOLE_ASYNC); } return 0; } @@ -518,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. @@ -614,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 @@ -625,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; @@ -636,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. + */ + + SetEvent(consolePtr->stopWriter); + + /* + * Wait at most 20 milliseconds for the writer thread to close. */ - WaitForSingleObject(consolePtr->writer.readyEvent, INFINITE); + 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 @@ -675,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; } @@ -684,7 +657,7 @@ ConsoleCloseProc( ckfree(consolePtr->writeBuf); consolePtr->writeBuf = 0; } - ckfree(consolePtr); + ckfree((char*) consolePtr); return errorCode; } @@ -715,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; @@ -750,7 +723,7 @@ ConsoleInputProc( bytesRead = infoPtr->bytesRead - infoPtr->offset; /* - * Reset the buffer. + * Reset the buffer */ infoPtr->readFlags &= ~CONSOLE_BUFFERED; @@ -766,15 +739,8 @@ ConsoleInputProc( * byte is available or an EOF occurs. */ - if (ReadConsoleBytes(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize, - &count) == TRUE) { - /* - * TODO: This potentially writes beyond the limits specified - * by the caller. In practice this is harmless, since all writes - * are into ChannelBuffers, and those have padding, but still - * ought to remove this, unless some Windows wizard can give - * a reason not to. - */ + if (readConsoleBytes(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize, &count) + == TRUE) { buf[count] = '\0'; return count; } @@ -803,23 +769,22 @@ 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. */ - errno = EWOULDBLOCK; + errno = EAGAIN; goto error; } @@ -848,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 { /* @@ -861,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; } @@ -901,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); @@ -920,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; } } @@ -941,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; } } @@ -989,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); @@ -1001,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; @@ -1044,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; } @@ -1082,7 +1046,6 @@ WaitForRead( { DWORD timeout, count; HANDLE *handle = infoPtr->handle; - ConsoleThreadInfo *threadInfo = &infoPtr->reader; INPUT_RECORD input; while (1) { @@ -1091,14 +1054,13 @@ 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. */ - errno = EWOULDBLOCK; + errno = EAGAIN; return -1; } @@ -1151,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); } } @@ -1179,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 (;;) { /* @@ -1213,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. @@ -1221,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; } } @@ -1233,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 @@ -1247,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); @@ -1279,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 (;;) { /* @@ -1317,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; } /* @@ -1331,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 @@ -1367,7 +1323,7 @@ ConsoleWriterThread( * Returns the new channel, or NULL. * * Side effects: - * May open the channel. + * May open the channel * *---------------------------------------------------------------------- */ @@ -1380,7 +1336,7 @@ TclWinOpenConsoleChannel( { char encoding[4 + TCL_INTEGER_SPACE]; ConsoleInfo *infoPtr; - DWORD modes; + DWORD id, modes; ConsoleInit(); @@ -1388,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; @@ -1405,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) { /* @@ -1421,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); } /* @@ -1435,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; } @@ -1464,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 30079b9..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,7 +293,7 @@ static const unsigned char errorTable[] = { * errno errors. */ -static const unsigned char wsaErrorTable[] = { +static CONST int wsaErrorTable[] = { EWOULDBLOCK, /* WSAEWOULDBLOCK */ EINPROGRESS, /* WSAEINPROGRESS */ EALREADY, /* WSAEALREADY */ @@ -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. * *---------------------------------------------------------------------- */ -TCL_NORETURN void -tclWinDebugPanic( - const char *format, ...) +void +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 52ea8c6..441337e 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}, @@ -71,7 +71,7 @@ const TclFileAttrProcs tclpFileAttrProcs[] = { * Prototype for the TraverseWinTree callback function. */ -typedef int (TraversalProc)(const TCHAR *srcPtr, const TCHAR *dstPtr, +typedef int (TraversalProc)(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr, int type, Tcl_DString *errorPtr); /* @@ -82,18 +82,18 @@ static void StatError(Tcl_Interp *interp, Tcl_Obj *fileName); static int ConvertFileNameFormat(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, int longShort, Tcl_Obj **attributePtrPtr); -static int DoCopyFile(const TCHAR *srcPtr, const TCHAR *dstPtr); -static int DoCreateDirectory(const TCHAR *pathPtr); -static int DoRemoveJustDirectory(const TCHAR *nativeSrc, +static int DoCopyFile(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr); +static int DoCreateDirectory(CONST TCHAR *pathPtr); +static int DoRemoveJustDirectory(CONST TCHAR *nativeSrc, int ignoreError, Tcl_DString *errorPtr); static int DoRemoveDirectory(Tcl_DString *pathPtr, int recursive, Tcl_DString *errorPtr); -static int DoRenameFile(const TCHAR *nativeSrc, - const TCHAR *dstPtr); -static int TraversalCopy(const TCHAR *srcPtr, const TCHAR *dstPtr, +static int DoRenameFile(CONST TCHAR *nativeSrc, + CONST TCHAR *dstPtr); +static int TraversalCopy(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr, int type, Tcl_DString *errorPtr); -static int TraversalDelete(const TCHAR *srcPtr, - const TCHAR *dstPtr, int type, +static int TraversalDelete(CONST TCHAR *srcPtr, + CONST TCHAR *dstPtr, int type, Tcl_DString *errorPtr); static int TraverseWinTree(TraversalProc *traverseProc, Tcl_DString *sourcePtr, Tcl_DString *dstPtr, @@ -151,9 +151,9 @@ TclpObjRenameFile( static int DoRenameFile( - const TCHAR *nativeSrc, /* Pathname of file or dir to be renamed + CONST TCHAR *nativeSrc, /* Pathname of file or dir to be renamed * (native). */ - const TCHAR *nativeDst) /* New pathname for file or directory + CONST TCHAR *nativeDst) /* New pathname for file or directory * (native). */ { #if defined(HAVE_NO_SEH) && !defined(_WIN64) @@ -256,7 +256,7 @@ DoRenameFile( [registration] "m" (registration), [nativeDst] "m" (nativeDst), [nativeSrc] "m" (nativeSrc), - [moveFile] "r" (MoveFile) + [moveFile] "r" (tclWinProcs->moveFileProc) : "%eax", "%ebx", "%ecx", "%edx", "memory" ); @@ -267,7 +267,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 @@ -281,10 +281,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; @@ -292,7 +292,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; @@ -308,28 +308,28 @@ DoRenameFile( decode: if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) { TCHAR *nativeSrcRest, *nativeDstRest; - const char **srcArgv, **dstArgv; + CONST char **srcArgv, **dstArgv; int size, srcArgc, dstArgc; - 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 @@ -376,8 +376,8 @@ DoRenameFile( Tcl_SetErrno(EXDEV); } - ckfree(srcArgv); - ckfree(dstArgv); + ckfree((char *) srcArgv); + ckfree((char *) dstArgv); } /* @@ -408,7 +408,7 @@ DoRenameFile( * directory back, for completeness. */ - if (MoveFile(nativeSrc, + if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) { return TCL_OK; } @@ -419,8 +419,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. @@ -447,20 +447,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 @@ -468,16 +470,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); } } @@ -540,8 +545,8 @@ TclpObjCopyFile( static int DoCopyFile( - const TCHAR *nativeSrc, /* Pathname of file to be copied (native). */ - const TCHAR *nativeDst) /* Pathname of file to copy to (native). */ + CONST TCHAR *nativeSrc, /* Pathname of file to be copied (native). */ + CONST TCHAR *nativeDst) /* Pathname of file to copy to (native). */ { #if defined(HAVE_NO_SEH) && !defined(_WIN64) TCLEXCEPTION_REGISTRATION registration; @@ -644,7 +649,7 @@ DoCopyFile( [registration] "m" (registration), [nativeDst] "m" (nativeDst), [nativeSrc] "m" (nativeSrc), - [copyFile] "r" (CopyFile) + [copyFile] "r" (tclWinProcs->copyFileProc) : "%eax", "%ebx", "%ecx", "%edx", "memory" ); @@ -655,7 +660,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 @@ -675,8 +680,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; @@ -692,9 +697,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; } @@ -705,7 +710,7 @@ DoCopyFile( */ TclWinConvertError(GetLastError()); - SetFileAttributes(nativeDst, dstAttr); + (*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr); } } } @@ -746,35 +751,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; } } @@ -788,21 +792,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) { /* @@ -859,11 +863,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; } @@ -992,12 +996,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); } @@ -1009,7 +1014,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. */ @@ -1029,7 +1034,7 @@ DoRemoveJustDirectory( goto end; } - attr = GetFileAttributes(nativePath); + attr = (*tclWinProcs->getFileAttributesProc)(nativePath); if (attr & FILE_ATTRIBUTE_REPARSE_POINT) { /* @@ -1043,7 +1048,7 @@ DoRemoveJustDirectory( * Ordinary directory. */ - if (RemoveDirectory(nativePath) != FALSE) { + if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) { return TCL_OK; } } @@ -1051,7 +1056,7 @@ DoRemoveJustDirectory( TclWinConvertError(GetLastError()); if (Tcl_GetErrno() == EACCES) { - attr = GetFileAttributes(nativePath); + attr = (*tclWinProcs->getFileAttributesProc)(nativePath); if (attr != 0xffffffff) { if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) { /* @@ -1075,17 +1080,60 @@ 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 and Win32s report removing a non-empty directory as + * EACCES, not EEXIST. If the directory is not empty, change errno + * so caller knows what's going on. + */ + + if (TclWinGetPlatformId() != VER_PLATFORM_WIN32_NT) { + CONST char *path, *find; + HANDLE handle; + WIN32_FIND_DATAA data; + Tcl_DString buffer; + int len; + + path = (CONST char *) nativePath; + + Tcl_DStringInit(&buffer); + len = strlen(path); + find = Tcl_DStringAppend(&buffer, path, len); + if ((len > 0) && (find[len - 1] != '\\')) { + Tcl_DStringAppend(&buffer, "\\", 1); + } + find = Tcl_DStringAppend(&buffer, "*.*", 3); + handle = FindFirstFileA(find, &data); + if (handle != INVALID_HANDLE_VALUE) { + while (1) { + if ((strcmp(data.cFileName, ".") != 0) + && (strcmp(data.cFileName, "..") != 0)) { + /* + * Found something in this directory. + */ + + Tcl_SetErrno(EEXIST); + break; + } + if (FindNextFileA(handle, &data) == FALSE) { + break; + } + } + FindClose(handle); + } + Tcl_DStringFree(&buffer); + } } } @@ -1130,7 +1178,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)) { @@ -1184,7 +1232,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; @@ -1195,7 +1243,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; @@ -1206,7 +1254,7 @@ TraverseWinTree( * Process the symbolic link */ - return traverseProc(nativeSource, nativeTarget, DOTREE_LINK, + return (*traverseProc)(nativeSource, nativeTarget, DOTREE_LINK, errorPtr); } @@ -1215,14 +1263,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. @@ -1233,44 +1285,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. @@ -1315,8 +1390,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); } @@ -1351,8 +1426,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. */ @@ -1370,9 +1445,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; } @@ -1417,8 +1492,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. */ @@ -1473,8 +1548,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); } /* @@ -1504,11 +1579,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); @@ -1526,7 +1601,7 @@ GetWinFileAttributes( */ int len; - const char *str = Tcl_GetStringFromObj(fileName,&len); + char *str = Tcl_GetStringFromObj(fileName,&len); if (len < 4) { if (len == 0) { @@ -1592,11 +1667,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; } @@ -1637,10 +1710,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; @@ -1656,7 +1729,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 @@ -1665,7 +1738,7 @@ ConvertFileNameFormat( * root directory */ - attr = GetFileAttributes(nativeName); + attr = (*tclWinProcs->getFileAttributesProc)(nativeName); if ((attr!=0xFFFFFFFF) && (attr & FILE_ATTRIBUTE_DIRECTORY)) { Tcl_DStringFree(&ds); goto simple; @@ -1679,14 +1752,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; + } } } @@ -1704,21 +1790,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); } } @@ -1830,12 +1917,13 @@ SetWinFileAttributes( Tcl_Obj *fileName, /* The name of the file. */ Tcl_Obj *attributePtr) /* The new value of the attribute. */ { - DWORD fileAttributes, old; - int yesNo, result; - const TCHAR *nativeName; + DWORD fileAttributes; + int yesNo; + int result; + CONST TCHAR *nativeName; nativeName = Tcl_FSGetNativePath(fileName); - fileAttributes = old = GetFileAttributes(nativeName); + fileAttributes = (*tclWinProcs->getFileAttributesProc)(nativeName); if (fileAttributes == 0xffffffff) { StatError(interp, fileName); @@ -1853,8 +1941,7 @@ SetWinFileAttributes( fileAttributes &= ~(attributeArray[objIndex]); } - if ((fileAttributes != old) - && !SetFileAttributes(nativeName, fileAttributes)) { + if (!(*tclWinProcs->setFileAttributesProc)(nativeName, fileAttributes)) { StatError(interp, fileName); return TCL_ERROR; } @@ -1885,13 +1972,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; } + /* *--------------------------------------------------------------------------- @@ -1909,7 +1996,7 @@ CannotSetAttribute( *--------------------------------------------------------------------------- */ -Tcl_Obj * +Tcl_Obj* TclpObjListVolumes(void) { Tcl_Obj *resultPtr, *elemPtr; diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 25c6ea4..41de4a8 100755 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -16,12 +16,9 @@ #include "tclFileSystem.h" #include <winioctl.h> #include <shlobj.h> -#include <lm.h> /* For TclpGetUserHome(). */ +#include <lmaccess.h> /* For TclpGetUserHome(). */ #include <userenv.h> /* For TclpGetUserHome(). */ -#ifdef _MSC_VER -# pragma comment(lib, "userenv.lib") -#endif /* * The number of 100-ns intervals between the Windows system epoch (1601-01-01 * on the proleptic Gregorian calendar) and the Posix epoch (1970-01-01). @@ -144,6 +141,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. */ @@ -151,6 +170,18 @@ 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); + +typedef BOOL WINAPI GETPROFILESDIRECTORYPROC( + LPWSTR lpProfilesDir, LPDWORD lpcchSize +); + /* * Declarations for local functions defined in this file: */ @@ -176,7 +207,6 @@ static int WinLink(const TCHAR *LinkSource, const TCHAR *LinkTarget, int linkAction); static int WinSymLinkDirectory(const TCHAR *LinkDirectory, const TCHAR *LinkTarget); -MODULE_SCOPE TCL_NORETURN void tclWinDebugPanic(const char *format, ...); /* *-------------------------------------------------------------------- @@ -194,7 +224,7 @@ WinLink( const TCHAR *linkTargetPath, int linkAction) { - TCHAR tempFileName[MAX_PATH]; + WCHAR tempFileName[MAX_PATH]; TCHAR *tempFilePart; DWORD attr; @@ -202,8 +232,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. */ @@ -216,7 +246,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; @@ -226,8 +256,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. */ @@ -240,36 +270,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 { /* @@ -286,11 +323,12 @@ WinLink( */ Tcl_SetErrno(EISDIR); + return -1; } else { Tcl_SetErrno(ENODEV); + return -1; } } - return -1; } /* @@ -307,7 +345,7 @@ static Tcl_Obj * WinReadLink( const TCHAR *linkSourcePath) { - TCHAR tempFileName[MAX_PATH]; + WCHAR tempFileName[MAX_PATH]; TCHAR *tempFilePart; DWORD attr; @@ -315,8 +353,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. */ @@ -329,7 +367,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. @@ -345,9 +383,9 @@ WinReadLink( Tcl_SetErrno(ENOTDIR); return NULL; + } else { + return WinReadLinkDirectory(linkSourcePath); } - - return WinReadLinkDirectory(linkSourcePath); } /* @@ -486,8 +524,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, @@ -501,7 +540,7 @@ TclWinSymLinkDelete( } else { CloseHandle(hFile); if (!linkOnly) { - RemoveDirectory(linkOrigPath); + (*tclWinProcs->removeDirectoryProc)(linkOrigPath); } return 0; } @@ -541,7 +580,7 @@ WinReadLinkDirectory( Tcl_DString ds; const char *copy; - attr = GetFileAttributes(linkDirPath); + attr = (*tclWinProcs->getFileAttributesProc)(linkDirPath); if (!(attr & FILE_ATTRIBUTE_REPARSE_POINT)) { goto invalidError; } @@ -566,7 +605,6 @@ WinReadLinkDirectory( */ offset = 0; -#ifdef UNICODE if (reparseBuffer->MountPointReparseBuffer.PathBuffer[0] == L'\\') { /* * Check whether this is a mounted volume. @@ -628,9 +666,8 @@ WinReadLinkDirectory( offset = 4; } } -#endif /* UNICODE */ - Tcl_WinTCharToUtf((const TCHAR *) + Tcl_WinTCharToUtf((const char *) reparseBuffer->MountPointReparseBuffer.PathBuffer, (int) reparseBuffer->MountPointReparseBuffer .SubstituteNameLength, &ds); @@ -672,8 +709,9 @@ NativeReadReparse( HANDLE hFile; DWORD returnedLength; - hFile = CreateFile(linkDirPath, desiredAccess, FILE_SHARE_READ, NULL, OPEN_EXISTING, - FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL); + hFile = (*tclWinProcs->createFileProc)(linkDirPath, desiredAccess, FILE_SHARE_READ, + NULL, OPEN_EXISTING, + FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL); if (hFile == INVALID_HANDLE_VALUE) { /* @@ -731,7 +769,7 @@ NativeWriteReparse( * Create the directory - it must not already exist. */ - if (CreateDirectory(linkDirPath, NULL) == 0) { + if ((*tclWinProcs->createDirectoryProc)(linkDirPath, NULL) == 0) { /* * Error creating directory. */ @@ -739,9 +777,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. @@ -764,7 +802,7 @@ NativeWriteReparse( TclWinConvertError(GetLastError()); CloseHandle(hFile); - RemoveDirectory(linkDirPath); + (*tclWinProcs->removeDirectoryProc)(linkDirPath); return -1; } CloseHandle(hFile); @@ -777,65 +815,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. - * - *---------------------------------------------------------------------- - */ - -TCL_NORETURN void -tclWinDebugPanic( - const char *format, ...) -{ -#define TCL_MAX_WARN_LEN 1024 - va_list argList; - char buf[TCL_MAX_WARN_LEN * TCL_UTF_MAX]; - WCHAR msgString[TCL_MAX_WARN_LEN]; - - va_start(argList, format); - vsnprintf(buf, sizeof(buf), format, argList); - - msgString[TCL_MAX_WARN_LEN-1] = L'\0'; - MultiByteToWideChar(CP_UTF8, 0, buf, -1, msgString, TCL_MAX_WARN_LEN); - - /* - * Truncate MessageBox string if it is too long to not overflow the screen - * and cause possible oversized window error. - */ - - if (msgString[TCL_MAX_WARN_LEN-1] != L'\0') { - memcpy(msgString + (TCL_MAX_WARN_LEN - 5), L" ...", 5 * sizeof(WCHAR)); - } - if (IsDebuggerPresent()) { - OutputDebugStringW(msgString); - } else { - MessageBeep(MB_ICONEXCLAMATION); - MessageBoxW(NULL, msgString, L"Fatal Error", - MB_ICONSTOP | MB_OK | MB_TASKMODAL | MB_SETFOREGROUND); - } -#if defined(__GNUC__) - __builtin_trap(); -#elif defined(_WIN64) - __debugbreak(); -#elif defined(_MSC_VER) - _asm {int 3} -#else - DebugBreak(); -#endif - abort(); -} - -/* *--------------------------------------------------------------------------- * * TclpFindExecutable -- @@ -854,33 +833,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); } @@ -926,7 +900,6 @@ TclpMatchInDirectory( if (pattern == NULL || (*pattern == '\0')) { Tcl_Obj *norm = Tcl_FSGetNormalizedPath(NULL, pathPtr); - if (norm != NULL) { /* * Match a single file directly. @@ -934,16 +907,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); @@ -953,7 +933,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; @@ -982,10 +962,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; } @@ -1000,7 +979,7 @@ TclpMatchInDirectory( lastChar = dirName[dirLength -1]; if ((lastChar != '\\') && (lastChar != '/') && (lastChar != ':')) { - TclDStringAppendLiteral(&dsOrig, "/"); + Tcl_DStringAppend(&dsOrig, "/", 1); dirLength++; } dirName = Tcl_DStringValue(&dsOrig); @@ -1020,25 +999,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) { /* @@ -1052,9 +1031,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; @@ -1094,8 +1074,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) { @@ -1138,7 +1124,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 { @@ -1156,7 +1141,7 @@ TclpMatchInDirectory( */ Tcl_DStringFree(&ds); - } while (FindNextFile(handle, &data) == TRUE); + } while ((*tclWinProcs->findNextFileProc)(handle, &data) == TRUE); FindClose(handle); Tcl_DStringFree(&dsOrig); @@ -1329,80 +1314,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; @@ -1429,60 +1415,90 @@ 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; + HINSTANCE userenvInst; + 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 - * "{GetProfilesDirectory}/<user>". - */ - DWORD i, size = MAX_PATH; - GetProfilesDirectoryW(buf, &size); - for (i = 0; i < size; ++i){ - if (buf[i] == '\\') buf[i] = '/'; + + netapiInst = LoadLibraryA("netapi32.dll"); + userenvInst = LoadLibraryA("userenv.dll"); + if (netapiInst != NULL && userenvInst != NULL) { + NETAPIBUFFERFREEPROC *netApiBufferFreeProc; + NETGETDCNAMEPROC *netGetDCNameProc; + NETUSERGETINFOPROC *netUserGetInfoProc; + GETPROFILESDIRECTORYPROC *getProfilesDirectoryProc; + + netApiBufferFreeProc = (NETAPIBUFFERFREEPROC *) + GetProcAddress(netapiInst, "NetApiBufferFree"); + netGetDCNameProc = (NETGETDCNAMEPROC *) + GetProcAddress(netapiInst, "NetGetDCName"); + netUserGetInfoProc = (NETUSERGETINFOPROC *) + GetProcAddress(netapiInst, "NetUserGetInfo"); + getProfilesDirectoryProc = (GETPROFILESDIRECTORYPROC *) + GetProcAddress(userenvInst, "GetProfilesDirectoryW"); + if ((netUserGetInfoProc != NULL) && (netGetDCNameProc != NULL) + && (netApiBufferFreeProc != NULL) && (getProfilesDirectoryProc != NULL)) { + USER_INFO_1 *uiPtr, **uiPtrPtr = &uiPtr; + Tcl_DString ds; + int nameLen, badDomain; + char *domain; + WCHAR *wName, *wHomeDir, *wDomain, **wDomainPtr = &wDomain; + WCHAR buf[MAX_PATH]; + + badDomain = 0; + nameLen = -1; + wDomain = NULL; + domain = strchr(name, '@'); + if (domain != NULL) { + Tcl_DStringInit(&ds); + wName = Tcl_UtfToUniCharDString(domain + 1, -1, &ds); + badDomain = (netGetDCNameProc)(NULL, wName, + (LPBYTE *) wDomainPtr); + Tcl_DStringFree(&ds); + nameLen = domain - name; + } + if (badDomain == 0) { + Tcl_DStringInit(&ds); + wName = Tcl_UtfToUniCharDString(name, nameLen, &ds); + if ((netUserGetInfoProc)(wDomain, wName, 1, + (LPBYTE *) uiPtrPtr) == 0) { + wHomeDir = uiPtr->usri1_home_dir; + if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) { + Tcl_UniCharToUtfDString(wHomeDir, lstrlenW(wHomeDir), + bufferPtr); + } else { + /* + * User exists but has no home dir. Return + * "{GetProfilesDirectory}/<user>". + */ + DWORD i, size = MAX_PATH; + getProfilesDirectoryProc(buf, &size); + for (i = 0; i < size; ++i){ + if (buf[i] == '\\') buf[i] = '/'; + } + Tcl_UniCharToUtfDString(buf, size-1, bufferPtr); + Tcl_DStringAppend(bufferPtr, "/", -1); + Tcl_DStringAppend(bufferPtr, name, -1); + } + result = Tcl_DStringValue(bufferPtr); + (*netApiBufferFreeProc)((void *) uiPtr); } - Tcl_UniCharToUtfDString(buf, size-1, bufferPtr); - Tcl_DStringAppend(bufferPtr, "/", -1); - Tcl_DStringAppend(bufferPtr, name, -1); + 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(userenvInst); + FreeLibrary(netapiInst); } if (result == NULL) { /* @@ -1538,9 +1554,9 @@ NativeAccess( { DWORD attr; - attr = GetFileAttributes(nativePath); + attr = (*tclWinProcs->getFileAttributesProc)(nativePath); - if (attr == INVALID_FILE_ATTRIBUTES) { + if (attr == 0xffffffff) { /* * File might not exist. */ @@ -1596,8 +1612,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; @@ -1612,11 +1627,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); @@ -1650,7 +1665,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)) { @@ -1686,14 +1701,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. @@ -1702,7 +1717,7 @@ NativeAccess( goto accessError; } - RevertToSelf(); + (*tclWinProcs->revertToSelfProc)(); /* * Setup desiredAccess according to the access priveleges we are @@ -1729,7 +1744,7 @@ NativeAccess( * Perform access check using the token. */ - if (!AccessCheck(sdPtr, hToken, desiredAccess, + if (!(*tclWinProcs->accessCheckProc)(sdPtr, hToken, desiredAccess, &genMap, &privSet, &privSetSize, &grantedAccess, &accessYesNo)) { /* @@ -1759,7 +1774,6 @@ NativeAccess( } } -#endif /* !UNICODE */ return 0; } @@ -1779,22 +1793,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++; + + /* + * 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. + */ - if ((_tcsicmp(path+len-3, TEXT("exe")) == 0) - || (_tcsicmp(path+len-3, TEXT("com")) == 0) - || (_tcsicmp(path+len-3, TEXT("bat")) == 0)) { - return 1; + return 1; + } + } } return 0; } @@ -1822,12 +1869,12 @@ TclpObjChdir( int result; const TCHAR *nativePath; - nativePath = Tcl_FSGetNativePath(pathPtr); + nativePath = (const TCHAR *) Tcl_FSGetNativePath(pathPtr); if (!nativePath) { return -1; } - result = SetCurrentDirectory(nativePath); + result = (*tclWinProcs->setCurrentDirectoryProc)(nativePath); if (result == 0) { TclWinConvertError(GetLastError()); @@ -1864,16 +1911,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; } @@ -1882,12 +1927,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. @@ -1914,7 +1972,8 @@ TclpObjStat( TclWinFlushDirtyChannels(); - return NativeStat(Tcl_FSGetNativePath(pathPtr), statPtr, 0); + return NativeStat((const TCHAR *) Tcl_FSGetNativePath(pathPtr), + statPtr, 0); } /* @@ -1960,7 +2019,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); @@ -1999,24 +2058,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; @@ -2032,6 +2091,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); @@ -2063,12 +2162,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; @@ -2084,14 +2185,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", @@ -2203,9 +2305,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; } @@ -2235,20 +2336,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 @@ -2256,7 +2371,7 @@ TclpObjAccess( Tcl_Obj *pathPtr, int mode) { - return NativeAccess(Tcl_FSGetNativePath(pathPtr), mode); + return NativeAccess((const TCHAR *) Tcl_FSGetNativePath(pathPtr), mode); } int @@ -2272,7 +2387,8 @@ TclpObjLstat( TclWinFlushDirtyChannels(); - return NativeStat(Tcl_FSGetNativePath(pathPtr), statPtr, 1); + return NativeStat((const TCHAR *) Tcl_FSGetNativePath(pathPtr), + statPtr, 1); } #ifdef S_IFLNK @@ -2284,15 +2400,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; @@ -2304,7 +2420,7 @@ TclpObjLink( return NULL; } } else { - const TCHAR *LinkSource = Tcl_FSGetNativePath(pathPtr); + TCHAR *LinkSource = (TCHAR *) Tcl_FSGetNativePath(pathPtr); if (LinkSource == NULL) { return NULL; @@ -2312,7 +2428,7 @@ TclpObjLink( return WinReadLink(LinkSource); } } -#endif /* S_IFLNK */ +#endif /* *--------------------------------------------------------------------------- @@ -2338,7 +2454,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); @@ -2353,14 +2469,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); } @@ -2368,9 +2486,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 } @@ -2420,219 +2542,377 @@ 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); - currentPathEndPosition = path + nextCheckpoint; - if (*currentPathEndPosition == '/') { - currentPathEndPosition++; - } - while (1) { - char cur = *currentPathEndPosition; + if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_WINDOWS) { + /* + * We're on Win95, 98 or ME. There are two assumptions in this block + * of code. First that the native (NULL) encoding is basically ascii, + * and second that symbolic links are not possible. Both of these + * assumptions appear to be true of these operating systems. + */ - if ((cur=='/' || cur==0) && (path != currentPathEndPosition)) { - /* - * Reached directory separator, or end of string. - */ + int isDrive = 1; + Tcl_DString ds; + + currentPathEndPosition = path + nextCheckpoint; + if (*currentPathEndPosition == '/') { + currentPathEndPosition++; + } + + while (1) { + char cur = *currentPathEndPosition; + + if ((cur=='/' || cur==0) && (path != currentPathEndPosition)) { + /* + * Reached directory separator, or end of string. + */ - WIN32_FILE_ATTRIBUTE_DATA data; - const TCHAR *nativePath = Tcl_WinUtfToTChar(path, - currentPathEndPosition - path, &ds); + const char *nativePath = Tcl_UtfToExternalDString(NULL, path, + currentPathEndPosition - path, &ds); - if (GetFileAttributesEx(nativePath, - GetFileExInfoStandard, &data) != TRUE) { /* - * File doesn't exist. + * Now we convert the tail of the current path to its 'long + * form', and append it to 'dsNorm' which holds the current + * normalized path, if the file exists. */ if (isDrive) { - int len = WinIsReserved(path); + if (GetFileAttributesA(nativePath) + == INVALID_FILE_ATTRIBUTES) { + /* + * File doesn't exist. + */ - if (len > 0) { + if (isDrive) { + int len = WinIsReserved(path); + + if (len > 0) { + /* + * Actually it does exist - COM1, etc. + */ + + int i; + + for (i=0 ; i<len ; i++) { + if (nativePath[i] >= 'a') { + ((char *) nativePath)[i] -= ('a'-'A'); + } + } + Tcl_DStringAppend(&dsNorm, nativePath, len); + lastValidPathEnd = currentPathEndPosition; + } else if (nextCheckpoint == 0) { + /* Path starts with a drive designation + * that's not actually on the system. + * We still must normalize up past the + * first separator. [Bug 3603434] */ + currentPathEndPosition++; + } + } + Tcl_DStringFree(&ds); + break; + } + if (nativePath[0] >= 'a') { + ((char *) nativePath)[0] -= ('a' - 'A'); + } + Tcl_DStringAppend(&dsNorm, nativePath, + Tcl_DStringLength(&ds)); + } else { + char *checkDots = NULL; + + if (lastValidPathEnd[1] == '.') { + checkDots = lastValidPathEnd + 1; + while (checkDots < currentPathEndPosition) { + if (*checkDots != '.') { + checkDots = NULL; + break; + } + checkDots++; + } + } + if (checkDots != NULL) { + int dotLen = currentPathEndPosition-lastValidPathEnd; + + /* + * Path is just dots. We shouldn't really ever see a + * path like that. However, to be nice we at least + * don't mangle the path - we just add the dots as a + * path segment and continue + */ + + Tcl_DStringAppend(&dsNorm, (TCHAR *) + (nativePath + Tcl_DStringLength(&ds)-dotLen), + dotLen); + } else { /* - * Actually it does exist - COM1, etc. + * Normal path. */ - int i; + WIN32_FIND_DATA fData; + HANDLE handle; - for (i=0 ; i<len ; i++) { - WCHAR wc = ((WCHAR *) nativePath)[i]; + handle = FindFirstFileA(nativePath, &fData); + if (handle == INVALID_HANDLE_VALUE) { + if (GetFileAttributesA(nativePath) + == INVALID_FILE_ATTRIBUTES) { + /* + * File doesn't exist. + */ - if (wc >= L'a') { - wc -= (L'a' - L'A'); - ((WCHAR *) nativePath)[i] = wc; + Tcl_DStringFree(&ds); + break; } + + /* + * This is usually the '/' in 'c:/' at end of + * string. + */ + + Tcl_DStringAppend(&dsNorm,"/", 1); + } else { + char *nativeName; + + if (fData.cFileName[0] != '\0') { + nativeName = fData.cFileName; + } else { + nativeName = fData.cAlternateFileName; + } + FindClose(handle); + Tcl_DStringAppend(&dsNorm,"/", 1); + Tcl_DStringAppend(&dsNorm,nativeName,-1); } - Tcl_DStringAppend(&dsNorm, - (const char *)nativePath, - (int)(sizeof(WCHAR) * len)); - lastValidPathEnd = currentPathEndPosition; - } else if (nextCheckpoint == 0) { - /* Path starts with a drive designation - * that's not actually on the system. - * We still must normalize up past the - * first separator. [Bug 3603434] */ - currentPathEndPosition++; } } Tcl_DStringFree(&ds); - break; + lastValidPathEnd = currentPathEndPosition; + if (cur == 0) { + break; + } + + /* + * If we get here, we've got past one directory delimiter, so + * we know it is no longer a drive. + */ + + isDrive = 0; } + currentPathEndPosition++; + } + } else { + /* + * We're on WinNT (or 2000 or XP; something with an NT core). + */ - /* - * File 'nativePath' does exist if we get here. We now want to - * check if it is a symlink and otherwise continue with the - * rest of the path. - */ + int isDrive = 1; + Tcl_DString ds; - /* - * Check for symlinks, except at last component of path (we - * don't follow final symlinks). Also a drive (C:/) for - * example, may sometimes have the reparse flag set for some - * reason I don't understand. We therefore don't perform this - * check for drives. - */ + currentPathEndPosition = path + nextCheckpoint; + if (*currentPathEndPosition == '/') { + currentPathEndPosition++; + } + while (1) { + char cur = *currentPathEndPosition; + + if ((cur=='/' || cur==0) && (path != currentPathEndPosition)) { + /* + * Reached directory separator, or end of string. + */ - if (cur != 0 && !isDrive && - data.dwFileAttributes & FILE_ATTRIBUTE_REPARSE_POINT){ - Tcl_Obj *to = WinReadLinkDirectory(nativePath); + WIN32_FILE_ATTRIBUTE_DATA data; + const char *nativePath = Tcl_WinUtfToTChar(path, + currentPathEndPosition - path, &ds); - if (to != NULL) { + if ((*tclWinProcs->getFileAttributesExProc)(nativePath, + GetFileExInfoStandard, &data) != TRUE) { /* - * Read the reparse point ok. Now, reparse points need - * not be normalized, otherwise we could use: - * - * Tcl_GetStringFromObj(to, &pathLen); - * nextCheckpoint = pathLen; - * - * So, instead we have to start from the beginning. + * File doesn't exist. */ - nextCheckpoint = 0; - Tcl_AppendToObj(to, currentPathEndPosition, -1); + if (isDrive) { + int len = WinIsReserved(path); - /* - * Convert link to forward slashes. - */ + if (len > 0) { + /* + * Actually it does exist - COM1, etc. + */ - for (path = Tcl_GetString(to); *path != 0; path++) { - if (*path == '\\') { - *path = '/'; - } - } - path = Tcl_GetString(to); - currentPathEndPosition = path + nextCheckpoint; - if (temp != NULL) { - Tcl_DecrRefCount(temp); - } - temp = to; + int i; - /* - * Reset variables so we can restart normalization. - */ + for (i=0 ; i<len ; i++) { + WCHAR wc = ((WCHAR *) nativePath)[i]; - isDrive = 1; - Tcl_DStringFree(&dsNorm); + if (wc >= L'a') { + wc -= (L'a' - L'A'); + ((WCHAR *) nativePath)[i] = wc; + } + } + Tcl_DStringAppend(&dsNorm, nativePath, + (int)(sizeof(WCHAR) * len)); + lastValidPathEnd = currentPathEndPosition; + } else if (nextCheckpoint == 0) { + /* Path starts with a drive designation + * that's not actually on the system. + * We still must normalize up past the + * first separator. [Bug 3603434] */ + currentPathEndPosition++; + } + } Tcl_DStringFree(&ds); - continue; + break; } - } -#ifndef TclNORM_LONG_PATH - /* - * Now we convert the tail of the current path to its 'long - * form', and append it to 'dsNorm' which holds the current - * normalized path - */ + /* + * File 'nativePath' does exist if we get here. We now want to + * check if it is a symlink and otherwise continue with the + * rest of the path. + */ - if (isDrive) { - WCHAR drive = ((WCHAR *) nativePath)[0]; + /* + * Check for symlinks, except at last component of path (we + * don't follow final symlinks). Also a drive (C:/) for + * example, may sometimes have the reparse flag set for some + * reason I don't understand. We therefore don't perform this + * check for drives. + */ - if (drive >= L'a') { - drive -= (L'a' - L'A'); - ((WCHAR *) nativePath)[0] = drive; - } - Tcl_DStringAppend(&dsNorm, (const char *)nativePath, - Tcl_DStringLength(&ds)); - } else { - char *checkDots = NULL; - - if (lastValidPathEnd[1] == '.') { - checkDots = lastValidPathEnd + 1; - while (checkDots < currentPathEndPosition) { - if (*checkDots != '.') { - checkDots = NULL; - break; + if (cur != 0 && !isDrive && + data.dwFileAttributes & FILE_ATTRIBUTE_REPARSE_POINT){ + Tcl_Obj *to = WinReadLinkDirectory(nativePath); + + if (to != NULL) { + /* + * Read the reparse point ok. Now, reparse points need + * not be normalized, otherwise we could use: + * + * Tcl_GetStringFromObj(to, &pathLen); + * nextCheckpoint = pathLen + * + * So, instead we have to start from the beginning. + */ + + nextCheckpoint = 0; + Tcl_AppendToObj(to, currentPathEndPosition, -1); + + /* + * Convert link to forward slashes. + */ + + for (path = Tcl_GetString(to); *path != 0; path++) { + if (*path == '\\') { + *path = '/'; + } + } + path = Tcl_GetString(to); + currentPathEndPosition = path + nextCheckpoint; + if (temp != NULL) { + Tcl_DecrRefCount(temp); } - checkDots++; + temp = to; + + /* + * Reset variables so we can restart normalization. + */ + + isDrive = 1; + Tcl_DStringFree(&dsNorm); + Tcl_DStringInit(&dsNorm); + Tcl_DStringFree(&ds); + continue; } } - if (checkDots != NULL) { - int dotLen = currentPathEndPosition-lastValidPathEnd; - /* - * Path is just dots. We shouldn't really ever see a - * path like that. However, to be nice we at least - * don't mangle the path - we just add the dots as a - * path segment and continue. - */ +#ifndef TclNORM_LONG_PATH + /* + * Now we convert the tail of the current path to its 'long + * form', and append it to 'dsNorm' which holds the current + * normalized path + */ - Tcl_DStringAppend(&dsNorm, ((const char *)nativePath) - + Tcl_DStringLength(&ds) - - (dotLen * sizeof(TCHAR)), - (int)(dotLen * sizeof(TCHAR))); + if (isDrive) { + WCHAR drive = ((WCHAR *) nativePath)[0]; + if (drive >= L'a') { + drive -= (L'a' - L'A'); + ((WCHAR *) nativePath)[0] = drive; + } + Tcl_DStringAppend(&dsNorm, nativePath, + Tcl_DStringLength(&ds)); } else { - /* - * Normal path. - */ - - WIN32_FIND_DATAW fData; - HANDLE handle; + char *checkDots = NULL; + + if (lastValidPathEnd[1] == '.') { + checkDots = lastValidPathEnd + 1; + while (checkDots < currentPathEndPosition) { + if (*checkDots != '.') { + checkDots = NULL; + break; + } + checkDots++; + } + } + if (checkDots != NULL) { + int dotLen = currentPathEndPosition-lastValidPathEnd; - handle = FindFirstFileW((WCHAR *) nativePath, &fData); - if (handle == INVALID_HANDLE_VALUE) { /* - * This is usually the '/' in 'c:/' at end of - * string. + * Path is just dots. We shouldn't really ever see a + * path like that. However, to be nice we at least + * don't mangle the path - we just add the dots as a + * path segment and continue. */ - Tcl_DStringAppend(&dsNorm, (const char *) L"/", - sizeof(WCHAR)); + Tcl_DStringAppend(&dsNorm, (TCHAR *) + ((WCHAR*)(nativePath + Tcl_DStringLength(&ds)) + - dotLen), (int)(dotLen * sizeof(WCHAR))); } else { - WCHAR *nativeName; + /* + * Normal path. + */ + + WIN32_FIND_DATAW fData; + HANDLE handle; - if (fData.cFileName[0] != '\0') { - nativeName = fData.cFileName; + handle = FindFirstFileW((WCHAR *) nativePath, &fData); + if (handle == INVALID_HANDLE_VALUE) { + /* + * This is usually the '/' in 'c:/' at end of + * string. + */ + + Tcl_DStringAppend(&dsNorm, (const char *) L"/", + sizeof(WCHAR)); } else { - nativeName = fData.cAlternateFileName; + WCHAR *nativeName; + + if (fData.cFileName[0] != '\0') { + nativeName = fData.cFileName; + } else { + nativeName = fData.cAlternateFileName; + } + FindClose(handle); + Tcl_DStringAppend(&dsNorm, (const char *) L"/", + sizeof(WCHAR)); + Tcl_DStringAppend(&dsNorm, (TCHAR *) nativeName, + (int) (wcslen(nativeName)*sizeof(WCHAR))); } - FindClose(handle); - Tcl_DStringAppend(&dsNorm, (const char *) L"/", - sizeof(WCHAR)); - Tcl_DStringAppend(&dsNorm, - (const char *) nativeName, - (int) (wcslen(nativeName)*sizeof(WCHAR))); } } - } -#endif /* !TclNORM_LONG_PATH */ - Tcl_DStringFree(&ds); - lastValidPathEnd = currentPathEndPosition; - if (cur == 0) { - break; - } +#endif + Tcl_DStringFree(&ds); + lastValidPathEnd = currentPathEndPosition; + if (cur == 0) { + break; + } - /* - * If we get here, we've got past one directory delimiter, so - * we know it is no longer a drive. - */ + /* + * If we get here, we've got past one directory delimiter, so + * we know it is no longer a drive. + */ - isDrive = 0; + isDrive = 0; + } + currentPathEndPosition++; } - currentPathEndPosition++; #ifdef TclNORM_LONG_PATH /* @@ -2641,10 +2921,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. @@ -2653,11 +2933,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 } /* @@ -2672,9 +2951,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. @@ -2684,7 +2965,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); @@ -2695,9 +2976,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); @@ -2709,7 +2991,6 @@ TclpObjNormalizePath( if (temp != NULL) { Tcl_DecrRefCount(temp); } - return nextCheckpoint; } @@ -2849,7 +3130,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); @@ -2905,11 +3186,10 @@ ClientData TclNativeCreateNativeRep( Tcl_Obj *pathPtr) { - WCHAR *nativePathPtr = NULL; - const char *str; + char *nativePathPtr, *str; + Tcl_DString ds; Tcl_Obj *validPathPtr; - size_t len; - WCHAR *wp; + int len; if (TclFSCwdIsNative()) { /* @@ -2922,7 +3202,6 @@ TclNativeCreateNativeRep( if (validPathPtr == NULL) { return NULL; } - /* refCount of validPathPtr was already incremented in Tcl_FSGetTranslatedPath */ } else { /* * Make sure the normalized path is set. @@ -2932,86 +3211,87 @@ TclNativeCreateNativeRep( if (validPathPtr == NULL) { return NULL; } - /* validPathPtr returned from Tcl_FSGetNormalizedPath is owned by Tcl, so incr refCount here */ Tcl_IncrRefCount(validPathPtr); } - str = Tcl_GetString(validPathPtr); - len = validPathPtr->length; - - if (strlen(str)!=(unsigned int)len) { - /* String contains NUL-bytes. This is invalid. */ - goto done; - } - /* For a reserved device, strip a possible postfix ':' */ - len = WinIsReserved(str); - if (len == 0) { - /* Let MultiByteToWideChar check for other invalid sequences, like - * 0xC0 0x80 (== overlong NUL). See bug [3118489]: NUL in filenames */ - len = MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, 0, 0); - if (len==0) { - goto done; - } - } - /* Overallocate 6 chars, making some room for extended paths */ - wp = nativePathPtr = ckalloc( (len+6) * sizeof(WCHAR) ); - if (nativePathPtr==0) { - goto done; - } - MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, nativePathPtr, len+1); - /* - ** If path starts with "//?/" or "\\?\" (extended path), translate - ** any slashes to backslashes but leave the '?' intact - */ - if ((str[0]=='\\' || str[0]=='/') && (str[1]=='\\' || str[1]=='/') - && str[2]=='?' && (str[3]=='\\' || str[3]=='/')) { - wp[0] = wp[1] = wp[3] = '\\'; - str += 4; - wp += 4; - } - /* - ** If there is no "\\?\" prefix but there is a drive or UNC - ** path prefix and the path is larger than MAX_PATH chars, - ** no Win32 API function can handle that unless it is - ** prefixed with the extended path prefix. See: - ** <http://msdn.microsoft.com/en-us/library/aa365247(VS.85).aspx#maxpath> - **/ - if (((str[0]>='A'&&str[0]<='Z') || (str[0]>='a'&&str[0]<='z')) - && str[1]==':') { - if (wp==nativePathPtr && len>MAX_PATH && (str[2]=='\\' || str[2]=='/')) { - memmove(wp+4, wp, len*sizeof(WCHAR)); - memcpy(wp, L"\\\\?\\", 4*sizeof(WCHAR)); + str = Tcl_GetStringFromObj(validPathPtr, &len); + Tcl_WinUtfToTChar(str, len, &ds); + if (tclWinProcs->useWide) { + WCHAR *wp = (WCHAR *) Tcl_DStringValue(&ds); + /* For a reserved device, strip a possible postfix ':' */ + len = WinIsReserved(str); + /* For normal devices */ + if (len == 0) len = Tcl_DStringLength(&ds)>>1; + /* + ** If path starts with "//?/" or "\\?\" (extended path), translate + ** any slashes to backslashes but accept the '?' as being valid. + */ + if ((str[0]=='\\' || str[0]=='/') && (str[1]=='\\' || str[1]=='/') + && str[2]=='?' && (str[3]=='\\' || str[3]=='/')) { + wp[0] = wp[1] = wp[3] = '\\'; + str += 4; wp += 4; + len -= 4; } /* - ** If (remainder of) path starts with "<drive>:", - ** leave the ':' intact. - */ - wp += 2; - } else if (wp==nativePathPtr && len>MAX_PATH - && (str[0]=='\\' || str[0]=='/') - && (str[1]=='\\' || str[1]=='/') && str[2]!='?') { - memmove(wp+6, wp, len*sizeof(WCHAR)); - memcpy(wp, L"\\\\?\\UNC", 7*sizeof(WCHAR)); - wp += 7; - } - /* - ** In the remainder of the path, translate invalid characters to - ** characters in the Unicode private use area. - */ - while (*wp != '\0') { - if ((*wp < ' ') || wcschr(L"\"*:<>?|", *wp)) { - *wp |= 0xF000; - } else if (*wp == '/') { - *wp = '\\'; + ** If there is a drive prefix, the ':' must be considered valid. + **/ + if (((str[0]>='A'&&str[0]<='Z') || (str[0]>='a'&&str[0]<='z')) + && str[1]==':') { + wp += 2; + len -= 2; } - ++wp; + while (len-->0) { + if ((*wp < ' ') || wcschr(L"\"*:<>?|", *wp)) { + Tcl_DecrRefCount(validPathPtr); + Tcl_DStringFree(&ds); + return NULL; + } else if (*wp=='/') { + *wp = '\\'; + } + ++wp; + } + len = Tcl_DStringLength(&ds) + sizeof(WCHAR); + } else { + char *p = Tcl_DStringValue(&ds); + len = Tcl_DStringLength(&ds); + /* + ** If path starts with "//?/" or "\\?\" (extended path), translate + ** any slashes to backslashes but accept the '?' as being valid. + */ + if ((str[0]=='\\' || str[0]=='/') && (str[1]=='\\' || str[1]=='/') + && str[2]=='?' && (str[3]=='\\' || str[3]=='/')) { + p[0] = p[1] = p[3] = '\\'; + str += 4; + p += 4; + len -= 4; + } + /* + ** If there is a drive prefix, the ':' must be considered valid. + **/ + if (((str[0]>='A'&&str[0]<='Z') || (str[0]>='a'&&str[0]<='z')) + && str[1]==':') { + p += 2; + len -= 2; + } + while (len-->0) { + if ((*p < ' ') || strchr("\"*:<>?|", *p)) { + Tcl_DecrRefCount(validPathPtr); + Tcl_DStringFree(&ds); + return NULL; + } else if (*p=='/') { + *p = '\\'; + } + ++p; + } + len = Tcl_DStringLength(&ds) + sizeof(char); } + Tcl_DecrRefCount(validPathPtr); + nativePathPtr = ckalloc((unsigned) len); + memcpy(nativePathPtr, Tcl_DStringValue(&ds), (size_t) len); - done: - - TclDecrRefCount(validPathPtr); - return nativePathPtr; + Tcl_DStringFree(&ds); + return (ClientData) nativePathPtr; } /* @@ -3042,11 +3322,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; } /* @@ -3081,9 +3373,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; @@ -3094,8 +3386,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 8b600f6..4e860b2 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); /* *--------------------------------------------------------------------------- @@ -135,11 +135,11 @@ TclpInitPlatform(void) tclPlatform = TCL_PLATFORM_WINDOWS; - /* - * Initialize the winsock library. On Windows XP and higher this - * can never fail. - */ - WSAStartup(wVersionRequested, &wsaData); + /* + * Initialize the winsock library. On Windows XP and higher this + * can never fail. + */ + WSAStartup(wVersionRequested, &wsaData); #ifdef STATIC_BUILD /* @@ -178,7 +178,7 @@ TclpInitLibraryPath( #define LIBRARY_SIZE 64 Tcl_Obj *pathPtr; char installLib[LIBRARY_SIZE]; - const char *bytes; + char *bytes; pathPtr = Tcl_NewObj(); @@ -215,7 +215,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); } @@ -242,14 +242,14 @@ TclpInitLibraryPath( static void AppendEnvironment( Tcl_Obj *pathPtr, - const char *lib) + CONST char *lib) { int pathc; WCHAR wBuf[MAX_PATH]; char buf[MAX_PATH * TCL_UTF_MAX]; Tcl_Obj *objPtr; Tcl_DString ds; - const char **pathv; + CONST char **pathv; char *shortlib; /* @@ -295,6 +295,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 @@ -304,13 +306,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); } } @@ -410,7 +413,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); } @@ -433,7 +436,7 @@ InitializeSourceLibraryDir( static int ToUtf( - const WCHAR *wSrc, + CONST WCHAR *wSrc, char *dst) { char *start; @@ -450,6 +453,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 @@ -482,13 +510,18 @@ TclpSetInitialEncodings(void) Tcl_DStringFree(&encodingName); } -void TclWinSetInterfaces( - int dummy) /* Not used. */ +void +TclpSetInterfaces(void) { - TclpSetInterfaces(); + int platformId, useWide; + + platformId = TclWinGetPlatformId(); + useWide = ((platformId == VER_PLATFORM_WIN32_NT) + || (platformId == VER_PLATFORM_WIN32_CE)); + TclWinSetInterfaces(useWide); } -const char * +CONST char * Tcl_GetEncodingNameFromEnvironment( Tcl_DString *bufPtr) { @@ -520,7 +553,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; @@ -529,7 +562,7 @@ TclpSetVariables( static OSVERSIONINFOW osInfo; static int osInfoInitialized = 0; Tcl_DString ds; - TCHAR szUserName[UNLEN+1]; + WCHAR szUserName[UNLEN+1]; DWORD cchUserNameLen = UNLEN; Tcl_SetVar2Ex(interp, "tclDefaultLibrary", NULL, @@ -568,7 +601,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 @@ -613,21 +646,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); } /* @@ -652,7 +679,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 @@ -660,7 +687,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; @@ -669,7 +696,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 9df424f..ccf48bb 100644 --- a/win/tclWinInt.h +++ b/win/tclWinInt.h @@ -32,6 +32,14 @@ typedef struct TCLEXCEPTION_REGISTRATION { #endif /* + * The following specifies how much stack space TclpCheckStackSpace() + * ensures is available. TclpCheckStackSpace() is called by Tcl_EvalObj() + * to help avoid overflowing the stack in the case of infinite recursion. + */ + +#define TCL_WIN_STACK_THRESHOLD 0x8000 + +/* * Some versions of Borland C have a define for the OSVERSIONINFO for * Win32s and for NT, but not for Windows 95. * Define VER_PLATFORM_WIN32_CE for those without newer headers. @@ -51,12 +59,124 @@ typedef struct TCLEXCEPTION_REGISTRATION { #endif /* + * The following structure keeps track of whether we are using the + * multi-byte or the wide-character interfaces to the operating system. + * System calls should be made through the following function table. + */ + +typedef union { + WIN32_FIND_DATAA a; + WIN32_FIND_DATAW w; +} WIN32_FIND_DATAT; + +typedef struct TclWinProcs { + int useWide; + + BOOL (WINAPI *buildCommDCBProc)(CONST TCHAR *, LPDCB); + TCHAR *(WINAPI *charLowerProc)(TCHAR *); + BOOL (WINAPI *copyFileProc)(CONST TCHAR *, CONST TCHAR *, BOOL); + BOOL (WINAPI *createDirectoryProc)(CONST TCHAR *, LPSECURITY_ATTRIBUTES); + HANDLE (WINAPI *createFileProc)(CONST TCHAR *, DWORD, DWORD, + LPSECURITY_ATTRIBUTES, DWORD, DWORD, HANDLE); + BOOL (WINAPI *createProcessProc)(CONST TCHAR *, TCHAR *, + LPSECURITY_ATTRIBUTES, LPSECURITY_ATTRIBUTES, BOOL, DWORD, + LPVOID, CONST TCHAR *, LPSTARTUPINFOA, LPPROCESS_INFORMATION); + BOOL (WINAPI *deleteFileProc)(CONST TCHAR *); + HANDLE (WINAPI *findFirstFileProc)(CONST TCHAR *, WIN32_FIND_DATAT *); + BOOL (WINAPI *findNextFileProc)(HANDLE, WIN32_FIND_DATAT *); + BOOL (WINAPI *getComputerNameProc)(WCHAR *, LPDWORD); + DWORD (WINAPI *getCurrentDirectoryProc)(DWORD, WCHAR *); + DWORD (WINAPI *getFileAttributesProc)(CONST TCHAR *); + DWORD (WINAPI *getFullPathNameProc)(CONST TCHAR *, DWORD nBufferLength, + WCHAR *, TCHAR **); + DWORD (WINAPI *getModuleFileNameProc)(HMODULE, WCHAR *, int); + DWORD (WINAPI *getShortPathNameProc)(CONST TCHAR *, WCHAR *, DWORD); + UINT (WINAPI *getTempFileNameProc)(CONST TCHAR *, CONST TCHAR *, UINT, + WCHAR *); + DWORD (WINAPI *getTempPathProc)(DWORD, WCHAR *); + BOOL (WINAPI *getVolumeInformationProc)(CONST TCHAR *, WCHAR *, DWORD, + LPDWORD, LPDWORD, LPDWORD, WCHAR *, DWORD); + HINSTANCE (WINAPI *loadLibraryExProc)(CONST TCHAR *, HANDLE, DWORD); + TCHAR (WINAPI *lstrcpyProc)(WCHAR *, CONST TCHAR *); + BOOL (WINAPI *moveFileProc)(CONST TCHAR *, CONST TCHAR *); + BOOL (WINAPI *removeDirectoryProc)(CONST TCHAR *); + DWORD (WINAPI *searchPathProc)(CONST TCHAR *, CONST TCHAR *, + CONST TCHAR *, DWORD, WCHAR *, TCHAR **); + BOOL (WINAPI *setCurrentDirectoryProc)(CONST TCHAR *); + BOOL (WINAPI *setFileAttributesProc)(CONST TCHAR *, DWORD); + /* + * These two function pointers will only be set when + * Tcl_FindExecutable is called. If you don't ever call that + * function, the application will crash whenever WinTcl tries to call + * functions through these null pointers. That is not a bug in Tcl + * -- Tcl_FindExecutable is obligatory in recent Tcl releases. + */ + BOOL (WINAPI *getFileAttributesExProc)(CONST TCHAR *, + GET_FILEEX_INFO_LEVELS, LPVOID); + BOOL (WINAPI *createHardLinkProc)(CONST TCHAR*, CONST TCHAR*, + LPSECURITY_ATTRIBUTES); + + /* deleted INT (__cdecl *utimeProc)(CONST TCHAR*, struct _utimbuf *); */ + /* These two are also NULL at start; see comment above */ + HANDLE (WINAPI *findFirstFileExProc)(CONST TCHAR*, UINT, + LPVOID, UINT, + LPVOID, DWORD); + BOOL (WINAPI *getVolumeNameForVMPProc)(CONST TCHAR*, TCHAR*, DWORD); + DWORD (WINAPI *getLongPathNameProc)(CONST TCHAR*, TCHAR*, DWORD); + /* + * These six are for the security sdk to get correct file + * permissions on NT, 2000, XP, etc. On 95,98,ME they are + * always null. + */ + BOOL (WINAPI *getFileSecurityProc)(LPCTSTR lpFileName, + SECURITY_INFORMATION RequestedInformation, + PSECURITY_DESCRIPTOR pSecurityDescriptor, + DWORD nLength, + LPDWORD lpnLengthNeeded); + BOOL (WINAPI *impersonateSelfProc) (SECURITY_IMPERSONATION_LEVEL + ImpersonationLevel); + BOOL (WINAPI *openThreadTokenProc) (HANDLE ThreadHandle, + DWORD DesiredAccess, BOOL OpenAsSelf, + PHANDLE TokenHandle); + BOOL (WINAPI *revertToSelfProc) (void); + VOID (WINAPI *mapGenericMaskProc) (PDWORD AccessMask, + PGENERIC_MAPPING GenericMapping); + BOOL (WINAPI *accessCheckProc)(PSECURITY_DESCRIPTOR pSecurityDescriptor, + HANDLE ClientToken, DWORD DesiredAccess, + PGENERIC_MAPPING GenericMapping, + PPRIVILEGE_SET PrivilegeSet, + LPDWORD PrivilegeSetLength, + LPDWORD GrantedAccess, + LPBOOL AccessStatus); + /* + * Unicode console support. WriteConsole and ReadConsole + */ + BOOL (WINAPI *readConsoleProc)( + HANDLE hConsoleInput, + LPVOID lpBuffer, + DWORD nNumberOfCharsToRead, + LPDWORD lpNumberOfCharsRead, + LPVOID lpReserved + ); + BOOL (WINAPI *writeConsoleProc)( + HANDLE hConsoleOutput, + const VOID* lpBuffer, + DWORD nNumberOfCharsToWrite, + LPDWORD lpNumberOfCharsWritten, + LPVOID lpReserved + ); + BOOL (WINAPI *getUserName)(LPTSTR lpBuffer, LPDWORD lpnSize); +} TclWinProcs; + +MODULE_SCOPE TclWinProcs *tclWinProcs; + +/* * Declarations of functions that are not accessible by way of the * stubs table. */ MODULE_SCOPE char TclWinDriveLetterForVolMountPoint( - const TCHAR *mountPoint); + CONST WCHAR *mountPoint); MODULE_SCOPE void TclWinEncodingsCleanup(); MODULE_SCOPE void TclWinInit(HINSTANCE hInst); MODULE_SCOPE TclFile TclWinMakeFile(HANDLE handle); @@ -66,11 +186,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 TclWinSerialOpen(HANDLE handle, const TCHAR *name, +MODULE_SCOPE void TclWinResetInterfaceEncodings(); +MODULE_SCOPE HANDLE TclWinSerialOpen(HANDLE handle, CONST TCHAR *name, DWORD access); -MODULE_SCOPE int TclWinSymLinkCopyDirectory(const TCHAR *LinkOriginal, - const TCHAR *LinkCopy); -MODULE_SCOPE int TclWinSymLinkDelete(const TCHAR *LinkOriginal, +MODULE_SCOPE int TclWinSymLinkCopyDirectory(CONST TCHAR* LinkOriginal, + CONST TCHAR* LinkCopy); +MODULE_SCOPE int TclWinSymLinkDelete(CONST TCHAR* LinkOriginal, int linkOnly); #if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) MODULE_SCOPE void TclWinFreeAllocCache(void); diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c index 26512b1..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, @@ -102,59 +105,40 @@ TclpDlopen( * better if there was a way to get what DLLs */ - if (interp) { - switch (lastError) { - case ERROR_MOD_NOT_FOUND: - Tcl_SetErrorCode(interp, "WIN_LOAD", "MOD_NOT_FOUND", NULL); - goto notFoundMsg; - case ERROR_DLL_NOT_FOUND: - Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_NOT_FOUND", NULL); - notFoundMsg: - Tcl_AppendToObj(errMsg, "this library or a dependent library" - " could not be found in library path", -1); - break; - case ERROR_PROC_NOT_FOUND: - Tcl_SetErrorCode(interp, "WIN_LOAD", "PROC_NOT_FOUND", NULL); - Tcl_AppendToObj(errMsg, "A function specified in the import" - " table could not be resolved by the system. Windows" - " is not telling which one, I'm sorry.", -1); - break; - case ERROR_INVALID_DLL: - Tcl_SetErrorCode(interp, "WIN_LOAD", "INVALID_DLL", NULL); - Tcl_AppendToObj(errMsg, "this library or a dependent library" - " is damaged", -1); - break; - case ERROR_DLL_INIT_FAILED: - Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_INIT_FAILED", NULL); - Tcl_AppendToObj(errMsg, "the library initialization" - " routine failed", -1); - break; - default: - TclWinConvertError(lastError); - Tcl_AppendToObj(errMsg, Tcl_PosixError(interp), -1); - } - Tcl_SetObjResult(interp, errMsg); + switch (lastError) { + case ERROR_MOD_NOT_FOUND: + case ERROR_DLL_NOT_FOUND: + Tcl_AppendResult(interp, "this library or a dependent library" + " could not be found in library path", NULL); + break; + case ERROR_PROC_NOT_FOUND: + Tcl_AppendResult(interp, "A function specified in the import" + " table could not be resolved by the system. Windows" + " is not telling which one, I'm sorry.", NULL); + break; + case ERROR_INVALID_DLL: + Tcl_AppendResult(interp, "this library or a dependent library" + " is damaged", NULL); + break; + case ERROR_DLL_INIT_FAILED: + Tcl_AppendResult(interp, "the library initialization" + " routine failed", NULL); + break; + default: + TclWinConvertError(lastError); + Tcl_AppendResult(interp, Tcl_PosixError(interp), NULL); } 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). @@ -167,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 @@ -218,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); } /* @@ -252,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. */ @@ -261,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 aff8836..ee088a5 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -50,7 +50,7 @@ TCL_DECLARE_MUTEX(pipeMutex) * used in a pipeline. */ -typedef struct { +typedef struct WinFile { int type; /* One of the file types defined above. */ HANDLE handle; /* Open file handle. */ } WinFile; @@ -82,12 +82,6 @@ static ProcInfo *procList; #define PIPE_EXTRABYTE (1<<3) /* The reader thread has consumed one byte. */ /* - * TODO: It appears the whole EXTRABYTE machinery is in place to support - * outdated Win 95 systems. If this can be confirmed, much code can be - * deleted. - */ - -/* * This structure describes per-instance data for a pipe based channel. */ @@ -148,7 +142,7 @@ typedef struct PipeInfo { * synchronized with the readable object. */ } PipeInfo; -typedef struct { +typedef struct ThreadSpecificData { /* * The following pointer refers to the head of the list of pipes that are * being watched for file events. @@ -164,7 +158,7 @@ static Tcl_ThreadDataKey dataKey; * events are generated. */ -typedef struct { +typedef struct PipeEvent { Tcl_Event header; /* Information that is standard for all * events. */ PipeInfo *infoPtr; /* Pointer to pipe info structure. Note that @@ -198,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); @@ -208,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. */ @@ -225,7 +219,7 @@ static const Tcl_ChannelType pipeChannelType = { NULL, /* handler proc. */ NULL, /* wide seek proc */ PipeThreadActionProc, /* thread action proc */ - NULL /* truncate */ + NULL, /* truncate */ }; /* @@ -410,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); @@ -441,7 +435,7 @@ TclWinMakeFile( { WinFile *filePtr; - filePtr = ckalloc(sizeof(WinFile)); + filePtr = (WinFile *) ckalloc(sizeof(WinFile)); filePtr->type = WIN_FILE; filePtr->handle = handle; @@ -470,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); } /* @@ -593,7 +596,7 @@ TclpOpenFile( flags = 0; if (!(mode & O_CREAT)) { - flags = GetFileAttributes(nativePath); + flags = (*tclWinProcs->getFileAttributesProc)(nativePath); if (flags == 0xFFFFFFFF) { flags = 0; } @@ -609,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) { @@ -657,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; @@ -666,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) { @@ -728,7 +731,7 @@ TclpCreateTempFile( TclWinConvertError(GetLastError()); CloseHandle(handle); - DeleteFile(name); + (*tclWinProcs->deleteFileProc)((TCHAR *) name); return NULL; } @@ -751,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); } /* @@ -833,7 +836,7 @@ TclpCloseFile( if (filePtr->handle != NULL && CloseHandle(filePtr->handle) == FALSE) { TclWinConvertError(GetLastError()); - ckfree(filePtr); + ckfree((char *) filePtr); return -1; } } @@ -843,7 +846,7 @@ TclpCloseFile( Tcl_Panic("TclpCloseFile: unexpected file type"); } - ckfree(filePtr); + ckfree((char *) filePtr); return 0; } @@ -944,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; @@ -1034,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; } @@ -1055,17 +1057,23 @@ TclpCreateProcess( * sink. */ - startInfo.hStdOutput = CreateFile(TEXT("NUL:"), GENERIC_WRITE, 0, - &secAtts, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL); + if ((TclWinGetPlatformId() == VER_PLATFORM_WIN32_WINDOWS) + && (applType == APPL_DOS)) { + if (CreatePipe(&h, &startInfo.hStdOutput, &secAtts, 0) != FALSE) { + CloseHandle(h); + } + } else { + startInfo.hStdOutput = CreateFileA("NUL:", GENERIC_WRITE, 0, + &secAtts, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL); + } } else { DuplicateHandle(hProcess, outputHandle, hProcess, &startInfo.hStdOutput, 0, TRUE, DUPLICATE_SAME_ACCESS); } if (startInfo.hStdOutput == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't duplicate output handle: %s", - Tcl_PosixError(interp))); + Tcl_AppendResult(interp, "couldn't duplicate output handle: ", + Tcl_PosixError(interp), (char *) NULL); goto end; } @@ -1075,7 +1083,7 @@ TclpCreateProcess( * sink. */ - startInfo.hStdError = CreateFile(TEXT("NUL:"), GENERIC_WRITE, 0, + startInfo.hStdError = CreateFileA("NUL:", GENERIC_WRITE, 0, &secAtts, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); } else { DuplicateHandle(hProcess, errorHandle, hProcess, &startInfo.hStdError, @@ -1083,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; } @@ -1117,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; } @@ -1129,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); } } @@ -1158,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; } @@ -1291,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"}; /* @@ -1317,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; @@ -1329,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, '.'); @@ -1342,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) { @@ -1409,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; } @@ -1422,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; @@ -1467,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++) { @@ -1477,7 +1555,7 @@ BuildCommandLine( arg = executable; } else { arg = argv[i]; - TclDStringAppendLiteral(&ds, " "); + Tcl_DStringAppend(&ds, " ", 1); } quote = 0; @@ -1486,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. */ @@ -1496,7 +1573,7 @@ BuildCommandLine( } } if (quote) { - TclDStringAppendLiteral(&ds, "\""); + Tcl_DStringAppend(&ds, "\"", 1); } start = arg; for (special = arg; ; ) { @@ -1525,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') { @@ -1535,7 +1612,7 @@ BuildCommandLine( } Tcl_DStringAppend(&ds, start, (int) (special - start)); if (quote) { - TclDStringAppendLiteral(&ds, "\""); + Tcl_DStringAppend(&ds, "\"", 1); } } Tcl_DStringFree(linePtr); @@ -1571,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(); @@ -1586,7 +1663,7 @@ TclpCreateCommandChannel( infoPtr->writeBuf = 0; infoPtr->writeBufLen = 0; infoPtr->writeError = 0; - infoPtr->channel = NULL; + infoPtr->channel = (Tcl_Channel) NULL; infoPtr->validMask = 0; @@ -1628,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 @@ -1638,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 @@ -1711,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. @@ -1723,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; } } @@ -1878,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 EWOULDBLOCK; - } - - } else { - - WaitForSingleObject(pipePtr->writable, INFINITE); - } + WaitForSingleObject(pipePtr->writable, INFINITE); /* * The thread may already have closed on it's own. Check its exit @@ -2007,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; } @@ -2021,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; @@ -2167,7 +2186,7 @@ PipeOutputProc( * the channel is in non-blocking mode. */ - errno = EWOULDBLOCK; + errno = EAGAIN; goto error; } @@ -2196,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; @@ -2575,7 +2594,7 @@ Tcl_WaitPid( */ CloseHandle(infoPtr->hProcess); - ckfree(infoPtr); + ckfree((char*)infoPtr); return result; } @@ -2601,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(); @@ -2645,15 +2664,17 @@ 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_GetString(objv[1]), + chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), NULL); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; @@ -2666,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); } @@ -2718,7 +2739,7 @@ WaitForRead( * is in non-blocking mode. */ - errno = EWOULDBLOCK; + errno = EAGAIN; return -1; } @@ -2960,10 +2981,6 @@ PipeWriterThread( * an error, so exit. */ - if (waitResult == WAIT_OBJECT_0) { - SetEvent(infoPtr->writable); - } - break; } @@ -3064,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_GetString(basenameObj); - - Tcl_WinUtfToTChar(string, basenameObj->length, &buf); - memcpy(namePtr, Tcl_DStringValue(&buf), Tcl_DStringLength(&buf)); - namePtr += Tcl_DStringLength(&buf); - Tcl_DStringFree(&buf); - } else { - const TCHAR *baseStr = TEXT("TCL"); - int length = 3 * sizeof(TCHAR); - - memcpy(namePtr, baseStr, length); - namePtr += length; - } - counter = TclpGetClicks() % 65533; - counter2 = 1024; /* Only try this many times! Prevents - * an infinite loop. */ - - do { - char number[TCL_INTEGER_SPACE + 4]; - - sprintf(number, "%d.TMP", counter); - counter = (unsigned short) (counter + 1); - Tcl_WinUtfToTChar(number, strlen(number), &buf); - Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf) + 1); - memcpy(namePtr, Tcl_DStringValue(&buf), Tcl_DStringLength(&buf) + 1); - Tcl_DStringFree(&buf); - - handle = CreateFile(name, - GENERIC_READ|GENERIC_WRITE, 0, NULL, CREATE_NEW, flags, NULL); - } while (handle == INVALID_HANDLE_VALUE - && --counter2 > 0 - && GetLastError() == ERROR_FILE_EXISTS); - if (handle == INVALID_HANDLE_VALUE) { - goto gotError; - } - - if (resultingNameObj) { - Tcl_Obj *tmpObj = TclpNativeToNormalized(name); - - Tcl_AppendObjToObj(resultingNameObj, tmpObj); - TclDecrRefCount(tmpObj); - } - - return Tcl_MakeFileChannel((ClientData) handle, - TCL_READABLE|TCL_WRITABLE); - - gotError: - TclWinConvertError(GetLastError()); - return NULL; -} - -/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/win/tclWinPort.h b/win/tclWinPort.h index ca6b2bf..b2bf1d7 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,20 +45,6 @@ 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. @@ -83,14 +52,16 @@ typedef DWORD_PTR * PDWORD_PTR; */ #include <time.h> -#include <wchar.h> #include <io.h> +#include <stdio.h> +#include <stdlib.h> #include <errno.h> #include <fcntl.h> #include <float.h> #include <malloc.h> #include <process.h> #include <signal.h> +#include <string.h> #include <limits.h> #ifndef __GNUC__ @@ -114,166 +85,108 @@ typedef DWORD_PTR * PDWORD_PTR; #endif /* __MWERKS__ */ /* + * Define EINPROGRESS in terms of WSAEINPROGRESS. + */ + +#undef EINPROGRESS +#define EINPROGRESS WSAEINPROGRESS + +/* + * Define ENOTSUP to a value that will never occur. + */ + +#undef ENOTSUP +#define ENOTSUP -1030507 + +/* Those codes, from Visual Studio 2010, conflict with other values */ +#undef ENODATA +#undef ENOMSG +#undef ENOSR +#undef ENOSTR +#undef EPROTO + +/* * The following defines redefine the Windows Socket errors as * BSD errors so Tcl_PosixError can do the right thing. */ -#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 @@ -472,6 +385,13 @@ typedef DWORD_PTR * PDWORD_PTR; # pragma warning(disable:4996) #endif + +/* + * There is no platform-specific panic routine for Windows in the Tcl internals. + */ + +#define TclpPanic ((Tcl_PanicProc *) NULL) + /* *--------------------------------------------------------------------------- * The following macros and declarations represent the interface between diff --git a/win/tclWinReg.c b/win/tclWinReg.c index 56aa991..a6ce2ce 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -12,48 +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 /* * 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 @@ -67,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 @@ -78,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 @@ -86,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 }; @@ -94,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, @@ -123,16 +185,16 @@ 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); -DLLEXPORT int Registry_Init(Tcl_Interp *interp); -DLLEXPORT int Registry_Unload(Tcl_Interp *interp, int flags); +EXTERN int Registry_Init(Tcl_Interp *interp); +EXTERN int Registry_Unload(Tcl_Interp *interp, int flags); /* *---------------------------------------------------------------------- @@ -156,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.1"); + (ClientData)interp, DeleteCmd); + Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, (ClientData)cmd); + return Tcl_PkgProvide(interp, "registry", "1.2.2"); } /* @@ -203,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); } @@ -233,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); } /* @@ -258,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; } @@ -399,22 +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_GetString(keyNameObj); - buffer = ckalloc(keyNameObj->length + 1); + keyName = Tcl_GetStringFromObj(keyNameObj, &length); + buffer = ckalloc((unsigned int) length + 1); strcpy(buffer, keyName); if (ParseKeyName(interp, buffer, &hostName, &rootKey, @@ -424,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; } @@ -439,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; } @@ -457,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) { @@ -494,12 +528,11 @@ 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; - size_t length; + int length; DWORD result; Tcl_DString ds; @@ -507,20 +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_GetString(valueNameObj); - length = valueNameObj->length; + 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 { @@ -553,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 */ @@ -573,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); @@ -647,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; - size_t length; + 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; } @@ -670,18 +702,17 @@ GetType( * Get the type of the value. */ - valueName = Tcl_GetString(valueNameObj); - length = valueNameObj->length; + 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; } @@ -720,22 +751,20 @@ 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; - size_t nameLen; + int nameLen; /* * 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; } @@ -751,13 +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_GetString(valueNameObj); - nameLen = valueNameObj->length; + 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) { /* @@ -766,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; @@ -791,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; @@ -803,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); @@ -855,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; @@ -892,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); @@ -944,13 +978,12 @@ OpenKey( HKEY *keyPtr) /* Returned HKEY. */ { char *keyName, *buffer, *hostName; - size_t length; + int length; HKEY rootKey; DWORD result; - keyName = Tcl_GetString(keyNameObj); - length = keyNameObj->length; - buffer = ckalloc(length + 1); + keyName = Tcl_GetStringFromObj(keyNameObj, &length); + buffer = ckalloc((unsigned int) length + 1); strcpy(buffer, keyName); result = ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName); @@ -1006,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) { @@ -1022,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); @@ -1098,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; } @@ -1152,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. @@ -1171,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); @@ -1246,32 +1251,29 @@ 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; - size_t length; 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; } - valueName = Tcl_GetString(valueNameObj); - length = valueNameObj->length; + valueName = Tcl_GetStringFromObj(valueNameObj, &length); valueName = (char *) Tcl_WinUtfToTChar(valueName, length, &nameBuf); if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) { @@ -1283,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; @@ -1305,53 +1307,53 @@ SetValue( Tcl_DStringInit(&data); for (i = 0; i < objc; i++) { - const char *bytes = Tcl_GetString(objv[i]); - - length = 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_GetString(dataObj); + CONST char *data = Tcl_GetStringFromObj(dataObj, &length); - length = 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; - int bytelength; /* * Store binary data in the registry. */ - data = (BYTE *) Tcl_GetByteArrayFromObj(dataObj, &bytelength); - result = RegSetValueEx(key, (TCHAR *) valueName, 0, - (DWORD) type, data, (DWORD) bytelength); + data = (BYTE *) Tcl_GetByteArrayFromObj(dataObj, &length); + result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, + (DWORD) type, data, (DWORD) length); } Tcl_DStringFree(&nameBuf); @@ -1387,29 +1389,34 @@ 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; - int timeout = 3000; - size_t len; - int unilen; - const char *str; + UINT timeout = 3000; + int len; + CONST char *str; Tcl_Obj *objPtr; - if (objc == 3) { - str = Tcl_GetString(objv[1]); - len = objv[1]->length; - if ((len < 2) || (*str != '-') || strncmp(str, "-timeout", len)) { - return TCL_BREAK; + if ((objc != 3) && (objc != 5)) { + Tcl_WrongNumArgs(interp, 2, objv, "keyName ?-timeout millisecs?"); + return TCL_ERROR; + } + + if (objc > 3) { + str = Tcl_GetStringFromObj(objv[3], &len); + if ((len < 2) || (*str != '-') + || strncmp(str, "-timeout", (size_t) len)) { + Tcl_WrongNumArgs(interp, 2, objv, "keyName ?-timeout millisecs?"); + return TCL_ERROR; } - if (Tcl_GetIntFromObj(interp, objv[2], &timeout) != TCL_OK) { + if (Tcl_GetIntFromObj(interp, objv[4], (int *) &timeout) != TCL_OK) { return TCL_ERROR; } } - str = (char*)Tcl_GetUnicodeFromObj(objv[0], &unilen); - if (unilen == 0) { + str = Tcl_GetStringFromObj(objv[2], &len); + if (len == 0) { str = NULL; } @@ -1418,7 +1425,7 @@ BroadcastValue( */ result = SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, - (WPARAM) 0, (LPARAM) str, SMTO_ABORTIFHUNG, (UINT) timeout, &sendResult); + (WPARAM) 0, (LPARAM) str, SMTO_ABORTIFHUNG, timeout, &sendResult); objPtr = Tcl_NewObj(); Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewLongObj((long) result)); @@ -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 0730a46..83f1866 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; @@ -932,7 +932,7 @@ SerialInputProc( bufSize = cStat.cbInQue; } } else { - errno = *errorCode = EWOULDBLOCK; + errno = *errorCode = EAGAIN; return -1; } } else { @@ -996,7 +996,7 @@ SerialInputProc( static int SerialOutputProc( ClientData instanceData, /* Serial state. */ - const char *buf, /* The data buffer. */ + CONST char *buf, /* The data buffer. */ int toWrite, /* How many bytes to write? */ int *errorCode) /* Where to store error code. */ { @@ -1071,7 +1071,7 @@ SerialOutputProc( ckfree(infoPtr->writeBuf); } infoPtr->writeBufLen = toWrite; - infoPtr->writeBuf = ckalloc(toWrite); + infoPtr->writeBuf = ckalloc((unsigned int) toWrite); } memcpy(infoPtr->writeBuf, buf, (size_t) toWrite); infoPtr->toWrite = toWrite; @@ -1415,7 +1415,7 @@ SerialWriterThread( * Opens or Reopens the serial port with the OVERLAPPED FLAG set * * Results: - * Returns the new handle, or INVALID_HANDLE_VALUE. + * Returns the new handle, or INVALID_HANDLE_VALUE. * If an existing channel is specified it is closed and reopened. * * Side effects: @@ -1427,7 +1427,7 @@ SerialWriterThread( HANDLE TclWinSerialOpen( HANDLE handle, - const TCHAR *name, + CONST TCHAR *name, DWORD access) { SerialInit(); @@ -1446,8 +1446,8 @@ TclWinSerialOpen( * finished */ - handle = 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; } @@ -1481,7 +1481,7 @@ TclWinOpenSerialChannel( SerialInit(); - infoPtr = ckalloc(sizeof(SerialInfo)); + infoPtr = (SerialInfo *) ckalloc((unsigned) sizeof(SerialInfo)); memset(infoPtr, 0, sizeof(SerialInfo)); infoPtr->validMask = permissions; @@ -1502,10 +1502,10 @@ TclWinOpenSerialChannel( * are shared between multiple channels (stdin/stdout). */ - sprintf(channelName, "file%" TCL_I_MODIFIER "x", (size_t) infoPtr); + sprintf(channelName, "file%" TCL_I_MODIFIER "x", (size_t)infoPtr); infoPtr->channel = Tcl_CreateChannel(&serialChannelType, channelName, - infoPtr, permissions); + (ClientData) infoPtr, permissions); SetupComm(handle, infoPtr->sysBufRead, infoPtr->sysBufWrite); @@ -1648,17 +1648,17 @@ static int SerialSetOptionProc( ClientData instanceData, /* File state. */ Tcl_Interp *interp, /* For error reporting - can be NULL. */ - const char *optionName, /* Which option to set? */ - const char *value) /* New value for option. */ + CONST char *optionName, /* Which option to set? */ + CONST char *value) /* New value for option. */ { SerialInfo *infoPtr; DCB dcb; BOOL result, flag; size_t len, vlen; Tcl_DString ds; - const TCHAR *native; + CONST TCHAR *native; int argc; - const char **argv; + CONST char **argv; infoPtr = (SerialInfo *) instanceData; @@ -1676,18 +1676,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; } @@ -1702,7 +1703,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; } @@ -1713,7 +1717,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; } /* @@ -1748,16 +1755,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; } @@ -1768,7 +1777,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) { @@ -1777,12 +1789,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; } @@ -1813,10 +1824,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; } @@ -1833,12 +1847,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; } @@ -1851,10 +1864,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; @@ -1863,10 +1873,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; @@ -1875,20 +1882,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; @@ -1896,7 +1898,7 @@ SerialSetOptionProc( } } - ckfree(argv); + ckfree((char *) argv); return result; } @@ -1922,24 +1924,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; } @@ -1952,12 +1950,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; } @@ -1987,10 +1991,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; } @@ -2000,22 +2001,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; } /* @@ -2043,7 +2028,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; @@ -2068,14 +2053,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; } @@ -2143,9 +2126,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; } @@ -2221,9 +2202,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; } @@ -2233,9 +2212,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 a022ed5..8f565b9 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -9,9 +9,6 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * ----------------------------------------------------------------------- - * The order and naming of functions in this file should minimize - * the file diff to tclUnixSock.c. - * ----------------------------------------------------------------------- * * General information on how this module works. * @@ -71,126 +68,64 @@ #undef setsockopt /* - * Helper macros to make parts of this file clearer. The macros do exactly - * what they say on the tin. :-) They also only ever refer to their arguments - * once, and so can be used without regard to side effects. - */ - -#define SET_BITS(var, bits) ((var) |= (bits)) -#define CLEAR_BITS(var, bits) ((var) &= ~(bits)) - -/* "sock" + a pointer in hex + \0 */ -#define SOCK_CHAN_LENGTH (4 + sizeof(void *) * 2 + 1) -#define SOCK_TEMPLATE "sock%p" - -/* * The following variable is used to tell whether this module has been * initialized. If 1, initialization of sockets was successful, if -1 then * socket initialization failed (WSAStartup failed). */ static int initialized = 0; -static const TCHAR classname[] = TEXT("TclSocket"); TCL_DECLARE_MUTEX(socketMutex) /* - * The following defines declare the messages used on socket windows. + * The following variable holds the network name of this host. */ -#define SOCKET_MESSAGE WM_USER+1 -#define SOCKET_SELECT WM_USER+2 -#define SOCKET_TERMINATE WM_USER+3 -#define SELECT TRUE -#define UNSELECT FALSE +static TclInitProcessGlobalValueProc InitializeHostName; +static ProcessGlobalValue hostName = { + 0, 0, NULL, NULL, InitializeHostName, NULL, NULL +}; /* - * This is needed to comply with the strict aliasing rules of GCC, but it also - * simplifies casting between the different sockaddr types. + * The following defines declare the messages used on socket windows. */ -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 +#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 structure describes per-instance state of a tcp based channel. + * The following structure is used to store the data associated with each + * socket. + * All members modified by the notifier thread are defined as volatile. */ -typedef struct TcpState TcpState; - -typedef struct TcpFdList { - TcpState *statePtr; - SOCKET fd; - struct TcpFdList *next; -} TcpFdList; - -struct TcpState { +typedef struct SocketInfo { Tcl_Channel channel; /* Channel associated with this socket. */ - struct TcpFdList *sockets; /* Windows SOCKET handle. */ - int flags; /* Bit field comprised of the flags described + SOCKET socket; /* Windows SOCKET handle. */ + volatile int flags; /* Bit field comprised of the flags described * below. */ int watchEvents; /* OR'ed combination of FD_READ, FD_WRITE, * FD_CLOSE, FD_ACCEPT and FD_CONNECT that * indicate which events are interesting. */ volatile int readyEvents; /* OR'ed combination of FD_READ, FD_WRITE, * FD_CLOSE, FD_ACCEPT and FD_CONNECT that - * indicate which events have occurred. - * Set by notifier thread, access must be - * protected by semaphore */ + * indicate which events have occurred. */ int selectEvents; /* OR'ed combination of FD_READ, FD_WRITE, * FD_CLOSE, FD_ACCEPT and FD_CONNECT that * indicate which events are currently being * selected. */ volatile int acceptEventCount; /* Count of the current number of FD_ACCEPTs - * that have arrived and not yet processed. - * Set by notifier thread, access must be - * protected by semaphore */ + * that have arrived and not yet processed. */ Tcl_TcpAcceptProc *acceptProc; /* Proc to call on accept. */ ClientData acceptProcData; /* The data for the accept proc. */ - - /* - * Only needed for client sockets - */ - - struct addrinfo *addrlist; /* Addresses to connect to. */ - struct addrinfo *addr; /* Iterator over addrlist. */ - struct addrinfo *myaddrlist;/* Local address. */ - struct addrinfo *myaddr; /* Iterator over myaddrlist. */ - int connectError; /* Cache status of async socket. */ - int cachedBlocking; /* Cache blocking mode of async socket. */ - volatile int notifierConnectError; - /* Async connect error set by notifier thread. - * This error is still a windows error code. - * Access must be protected by semaphore */ - struct TcpState *nextPtr; /* The next socket on the per-thread socket + volatile int lastError; /* Error code from last message. */ + struct SocketInfo *nextPtr; /* The next socket on the per-thread socket * list. */ -}; - -/* - * These bits may be ORed together into the "flags" field of a TcpState - * structure. - */ - -#define TCP_NONBLOCKING (1<<0) /* Socket with non-blocking I/O */ -#define TCP_ASYNC_CONNECT (1<<1) /* Async connect in progress. */ -#define SOCKET_EOF (1<<2) /* A zero read happened on the - * socket. */ -#define SOCKET_PENDING (1<<3) /* A message has been sent for this - * socket */ -#define TCP_ASYNC_PENDING (1<<4) /* TcpConnect was called to - * process an async connect. This - * flag indicates that reentry is - * still pending */ -#define TCP_ASYNC_FAILED (1<<5) /* An async connect finally failed */ +} SocketInfo; /* * The following structure is what is added to the Tcl event queue when a @@ -201,8 +136,8 @@ typedef struct { Tcl_Event header; /* Information that is standard for all * events. */ SOCKET socket; /* Socket descriptor that is ready. Used to - * find the TcpState structure for the file - * (can't point directly to the TcpState + * find the SocketInfo structure for the file + * (can't point directly to the SocketInfo * structure because it could go away while * the event is queued). */ } SocketEvent; @@ -213,6 +148,17 @@ typedef struct { #define TCP_BUFFER_SIZE 4096 +/* + * The following macros may be used to set the flags field of a SocketInfo + * structure. + */ + +#define SOCKET_ASYNC (1<<0) /* The socket is in blocking mode. */ +#define SOCKET_EOF (1<<1) /* A zero read happened on the + * socket. */ +#define SOCKET_ASYNC_CONNECT (1<<2) /* This socket uses async connect. */ +#define SOCKET_PENDING (1<<3) /* A message has been sent for this + * socket */ typedef struct { HWND hwnd; /* Handle to window for socket messages. */ @@ -223,11 +169,11 @@ typedef struct { * socketThread has been initialized and has * started. */ HANDLE socketListLock; /* Win32 Event to lock the socketList */ - TcpState *pendingTcpState; + SocketInfo *pendingSocketInfo; /* This socket is opened but not jet in the * list. This value is also checked by * the event structure. */ - TcpState *socketList; /* Every open socket in this thread has an + SocketInfo *socketList; /* Every open socket in this thread has an * entry on this list. */ } ThreadSpecificData; @@ -235,23 +181,23 @@ static Tcl_ThreadDataKey dataKey; static WNDCLASS windowClass; /* - * Static routines for this file: + * Static functions defined in this file. */ -static int TcpConnect(Tcl_Interp *interp, - TcpState *state); +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 TcpState * NewSocketInfo(SOCKET socket); +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 int WaitForConnect(TcpState *statePtr, int *errorCodePtr); -static int WaitForSocketEvent(TcpState *statePtr, int events, +static void TcpAccept(SocketInfo *infoPtr); +static int WaitForSocketEvent(SocketInfo *infoPtr, int events, int *errorCodePtr); -static void AddSocketInfoFd(TcpState *statePtr, SOCKET socket); -static int FindFDInList(TcpState *statePtr, SOCKET socket); static DWORD WINAPI SocketThread(LPVOID arg); static void TcpThreadActionProc(ClientData instanceData, int action); @@ -259,9 +205,8 @@ static void TcpThreadActionProc(ClientData instanceData, static Tcl_EventCheckProc SocketCheckProc; static Tcl_EventProc SocketEventProc; static Tcl_EventSetupProc SocketSetupProc; -static Tcl_DriverBlockModeProc TcpBlockModeProc; +static Tcl_DriverBlockModeProc TcpBlockProc; static Tcl_DriverCloseProc TcpCloseProc; -static Tcl_DriverClose2Proc TcpClose2Proc; static Tcl_DriverSetOptionProc TcpSetOptionProc; static Tcl_DriverGetOptionProc TcpGetOptionProc; static Tcl_DriverInputProc TcpInputProc; @@ -271,180 +216,192 @@ static Tcl_DriverGetHandleProc TcpGetHandleProc; /* * This structure describes the channel type structure for TCP socket - * based IO: + * based IO. */ -static const Tcl_ChannelType tcpChannelType = { - "tcp", /* Type name. */ - TCL_CHANNEL_VERSION_5, /* v5 channel */ - TcpCloseProc, /* Close proc. */ - TcpInputProc, /* Input proc. */ - TcpOutputProc, /* Output proc. */ - NULL, /* Seek proc. */ - TcpSetOptionProc, /* Set option proc. */ - TcpGetOptionProc, /* Get option proc. */ - TcpWatchProc, /* Initialize notifier. */ - TcpGetHandleProc, /* Get OS handles out of channel. */ - TcpClose2Proc, /* Close2 proc. */ - TcpBlockModeProc, /* Set blocking or non-blocking mode.*/ - NULL, /* flush proc. */ - NULL, /* handler proc. */ - NULL, /* wide seek proc. */ - TcpThreadActionProc, /* thread action proc. */ - NULL /* truncate proc. */ +static Tcl_ChannelType tcpChannelType = { + "tcp", /* Type name. */ + TCL_CHANNEL_VERSION_5, /* v5 channel */ + TcpCloseProc, /* Close proc. */ + TcpInputProc, /* Input proc. */ + TcpOutputProc, /* Output proc. */ + NULL, /* Seek proc. */ + TcpSetOptionProc, /* Set option proc. */ + TcpGetOptionProc, /* Get option proc. */ + TcpWatchProc, /* Set up notifier to watch this channel. */ + TcpGetHandleProc, /* Get an OS handle from channel. */ + NULL, /* close2proc. */ + TcpBlockProc, /* Set socket into (non-)blocking mode. */ + NULL, /* flush proc. */ + NULL, /* handler proc. */ + NULL, /* wide seek proc */ + TcpThreadActionProc, /* thread action proc */ + NULL, /* truncate */ }; - -/* - * The following variable holds the network name of this host. - */ - -static TclInitProcessGlobalValueProc InitializeHostName; -static ProcessGlobalValue hostName = - {0, 0, NULL, NULL, InitializeHostName, NULL, NULL}; - -/* - * Address print debug functions - */ -#if 0 -void printaddrinfo(struct addrinfo *ai, char *prefix) -{ - char host[NI_MAXHOST], port[NI_MAXSERV]; - getnameinfo(ai->ai_addr, ai->ai_addrlen, - host, sizeof(host), - port, sizeof(port), - NI_NUMERICHOST|NI_NUMERICSERV); -} -void printaddrinfolist(struct addrinfo *addrlist, char *prefix) -{ - struct addrinfo *ai; - for (ai = addrlist; ai != NULL; ai = ai->ai_next) { - printaddrinfo(ai, prefix); - } -} -#endif /* *---------------------------------------------------------------------- * - * InitializeHostName -- + * InitSockets -- * - * This routine sets the process global value of the name of the local - * host on which the process is running. + * Initialize the socket module. If winsock startup is successful, + * registers the event window for the socket notifier code. + * + * Assumes socketMutex is held. * * Results: * None. * + * Side effects: + * Initializes winsock, registers a new window class and creates a + * window for use in asynchronous socket notification. + * *---------------------------------------------------------------------- */ -void -InitializeHostName( - char **valuePtr, - int *lengthPtr, - Tcl_Encoding *encodingPtr) +static void +InitSockets(void) { - TCHAR tbuf[MAX_COMPUTERNAME_LENGTH + 1]; - DWORD length = MAX_COMPUTERNAME_LENGTH + 1; - Tcl_DString ds; + DWORD id; + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) + TclThreadDataKeyGet(&dataKey); + + if (!initialized) { + initialized = 1; + TclCreateLateExitHandler(SocketExitHandler, (ClientData) NULL); - if (GetComputerName(tbuf, &length) != 0) { /* - * Convert string from native to UTF then change to lowercase. + * Create the async notification window with a new class. We must + * create a new class to avoid a Windows 95 bug that causes us to get + * the wrong message number for socket events if the message window is + * a subclass of a static control. */ - Tcl_UtfToLower(Tcl_WinTCharToUtf(tbuf, -1, &ds)); + windowClass.style = 0; + windowClass.cbClsExtra = 0; + windowClass.cbWndExtra = 0; + windowClass.hInstance = TclWinGetTclInstance(); + windowClass.hbrBackground = NULL; + windowClass.lpszMenuName = NULL; + windowClass.lpszClassName = "TclSocket"; + windowClass.lpfnWndProc = SocketProc; + windowClass.hIcon = NULL; + windowClass.hCursor = NULL; - } else { - Tcl_DStringInit(&ds); - if (TclpHasSockets(NULL) == TCL_OK) { - /* - * The buffer size of 256 is recommended by the MSDN page that - * documents gethostname() as being always adequate. - */ + if (!RegisterClassA(&windowClass)) { + TclWinConvertError(GetLastError()); + goto initFailure; + } - Tcl_DString inDs; + } - Tcl_DStringInit(&inDs); - Tcl_DStringSetLength(&inDs, 256); - if (gethostname(Tcl_DStringValue(&inDs), - Tcl_DStringLength(&inDs)) == 0) { - Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&inDs), -1, - &ds); - } - Tcl_DStringFree(&inDs); + /* + * Check for per-thread initialization. + */ + + if (tsdPtr == NULL) { + tsdPtr = TCL_TSD_INIT(&dataKey); + tsdPtr->pendingSocketInfo = NULL; + tsdPtr->socketList = NULL; + tsdPtr->hwnd = NULL; + tsdPtr->threadId = Tcl_GetCurrentThread(); + tsdPtr->readyEvent = CreateEvent(NULL, FALSE, FALSE, NULL); + if (tsdPtr->readyEvent == NULL) { + goto initFailure; + } + tsdPtr->socketListLock = CreateEvent(NULL, FALSE, TRUE, NULL); + if (tsdPtr->socketListLock == NULL) { + goto initFailure; + } + tsdPtr->socketThread = CreateThread(NULL, 256, SocketThread, tsdPtr, + 0, &id); + if (tsdPtr->socketThread == NULL) { + goto initFailure; + } + + SetThreadPriority(tsdPtr->socketThread, THREAD_PRIORITY_HIGHEST); + + /* + * Wait for the thread to signal when the window has been created and + * if it is ready to go. + */ + + WaitForSingleObject(tsdPtr->readyEvent, INFINITE); + + if (tsdPtr->hwnd == NULL) { + goto initFailure; /* Trouble creating the window */ } + + Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL); } + return; - *encodingPtr = Tcl_GetEncoding(NULL, "utf-8"); - *lengthPtr = Tcl_DStringLength(&ds); - *valuePtr = ckalloc((*lengthPtr) + 1); - memcpy(*valuePtr, Tcl_DStringValue(&ds), (size_t)(*lengthPtr)+1); - Tcl_DStringFree(&ds); + initFailure: + TclpFinalizeSockets(); + initialized = -1; + return; } /* *---------------------------------------------------------------------- * - * Tcl_GetHostName -- + * SocketsEnabled -- * - * Returns the name of the local host. + * Check that the WinSock was successfully initialized. * * Results: - * A string containing the network name for this machine, or an empty - * string if we can't figure out the name. The caller must not modify or - * free this string. + * 1 if it is. * * Side effects: - * Caches the name to return for future calls. + * None. * *---------------------------------------------------------------------- */ -const char * -Tcl_GetHostName(void) + /* ARGSUSED */ +static int +SocketsEnabled(void) { - return Tcl_GetString(TclGetProcessGlobalValue(&hostName)); + int enabled; + Tcl_MutexLock(&socketMutex); + enabled = (initialized == 1); + Tcl_MutexUnlock(&socketMutex); + return enabled; } + /* *---------------------------------------------------------------------- * - * TclpHasSockets -- + * SocketExitHandler -- * - * This function determines whether sockets are available on the current - * system and returns an error in interp if they are not. Note that - * interp may be NULL. + * Callback invoked during exit clean up to delete the socket + * communication window and to release the WinSock DLL. * * Results: - * Returns TCL_OK if the system supports sockets, or TCL_ERROR with an - * error in interp (if non-NULL). + * None. * * Side effects: - * If not already prepared, initializes the TSD structure and socket - * message handling thread associated to the calling thread for the - * subsystem of the driver. + * None. * *---------------------------------------------------------------------- */ -int -TclpHasSockets( - Tcl_Interp *interp) /* Where to write an error message if sockets - * are not present, or NULL if no such message - * is to be written. */ + /* ARGSUSED */ +static void +SocketExitHandler( + ClientData clientData) /* Not used. */ { Tcl_MutexLock(&socketMutex); - InitSockets(); - Tcl_MutexUnlock(&socketMutex); + /* + * Make sure the socket event handling window is cleaned-up for, at + * most, this thread. + */ - if (SocketsEnabled()) { - return TCL_OK; - } - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "sockets are not available on this system", -1)); - } - return TCL_ERROR; + TclpFinalizeSockets(); + UnregisterClass("TclSocket", TclWinGetTclInstance()); + initialized = 0; + Tcl_MutexUnlock(&socketMutex); } /* @@ -469,490 +426,346 @@ TclpHasSockets( 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); } /* *---------------------------------------------------------------------- * - * TcpBlockModeProc -- + * TclpHasSockets -- * - * This function is invoked by the generic IO level to set blocking and - * nonblocking mode on a TCP socket based channel. + * This function determines whether sockets are available on the current + * system and returns an error in interp if they are not. Note that + * interp may be NULL. * * Results: - * 0 if successful, errno when failed. + * Returns TCL_OK if the system supports sockets, or TCL_ERROR with an + * error in interp (if non-NULL). * * Side effects: - * Sets the device into blocking or nonblocking mode. + * If not already prepared, initializes the TSD structure and socket + * message handling thread associated to the calling thread for the + * subsystem of the driver. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ -static int -TcpBlockModeProc( - ClientData instanceData, /* Socket state. */ - int mode) /* The mode to set. Can be one of - * TCL_MODE_BLOCKING or - * TCL_MODE_NONBLOCKING. */ +int +TclpHasSockets( + Tcl_Interp *interp) /* Where to write an error message if sockets + * are not present, or NULL if no such message + * is to be written. */ { - TcpState *statePtr = instanceData; + Tcl_MutexLock(&socketMutex); + InitSockets(); + Tcl_MutexUnlock(&socketMutex); - if (mode == TCL_MODE_NONBLOCKING) { - statePtr->flags |= TCP_NONBLOCKING; - } else { - statePtr->flags &= ~(TCP_NONBLOCKING); + if (SocketsEnabled()) { + return TCL_OK; } - return 0; + if (interp != NULL) { + Tcl_AppendResult(interp, "sockets are not available on this system", + NULL); + } + return TCL_ERROR; } /* *---------------------------------------------------------------------- * - * WaitForConnect -- - * - * Check the state of an async connect process. If a connection - * attempt terminated, process it, which may finalize it or may - * start the next attempt. If a connect error occures, it is saved - * in statePtr->connectError to be reported by 'fconfigure -error'. + * SocketSetupProc -- * - * There are two modes of operation, defined by errorCodePtr: - * * non-NULL: Called by explicite read/write command. block if - * socket is blocking. - * May return two error codes: - * * EWOULDBLOCK: if connect is still in progress - * * ENOTCONN: if connect failed. This would be the error - * message of a rect or sendto syscall so this is - * emulated here. - * * Null: Called by a backround operation. Do not block and - * don't return any error code. + * This function is invoked before Tcl_DoOneEvent blocks waiting for an + * event. * * Results: - * 0 if the connection has completed, -1 if still in progress - * or there is an error. + * None. * * Side effects: - * Processes socket events off the system queue. - * May process asynchroneous connect. + * Adjusts the block time if needed. * *---------------------------------------------------------------------- */ -static int -WaitForConnect( - TcpState *statePtr, /* State of the socket. */ - int *errorCodePtr) /* Where to store errors? - * A passed null-pointer activates background mode. - */ +void +SocketSetupProc( + ClientData data, /* Not used. */ + int flags) /* Event flags as passed to Tcl_DoOneEvent. */ { - int result; - int oldMode; - ThreadSpecificData *tsdPtr; - - /* - * Check if an async connect failed already and error reporting is demanded, - * return the error ENOTCONN - */ + SocketInfo *infoPtr; + Tcl_Time blockTime = { 0, 0 }; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - if (errorCodePtr != NULL && (statePtr->flags & TCP_ASYNC_FAILED)) { - *errorCodePtr = ENOTCONN; - return -1; + if (!(flags & TCL_FILE_EVENTS)) { + return; } /* - * Check if an async connect is running. If not return ok + * Check to see if there is a ready socket. If so, poll. */ - if (!(statePtr->flags & TCP_ASYNC_CONNECT)) { - return 0; + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + for (infoPtr = tsdPtr->socketList; infoPtr != NULL; + infoPtr = infoPtr->nextPtr) { + if (infoPtr->readyEvents & infoPtr->watchEvents) { + Tcl_SetMaxBlockTime(&blockTime); + break; + } } + SetEvent(tsdPtr->socketListLock); +} + +/* + *---------------------------------------------------------------------- + * + * SocketCheckProc -- + * + * This function is called by Tcl_DoOneEvent to check the socket event + * source for events. + * + * Results: + * None. + * + * Side effects: + * May queue an event. + * + *---------------------------------------------------------------------- + */ - /* - * Be sure to disable event servicing so we are truly modal. - */ +static void +SocketCheckProc( + ClientData data, /* Not used. */ + int flags) /* Event flags as passed to Tcl_DoOneEvent. */ +{ + SocketInfo *infoPtr; + SocketEvent *evPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - oldMode = Tcl_SetServiceMode(TCL_SERVICE_NONE); + if (!(flags & TCL_FILE_EVENTS)) { + return; + } /* - * Loop in the blocking case until the connect signal is present + * Queue events for any ready sockets that don't already have events + * queued (caused by persistent states that won't generate WinSock + * events). */ - while (1) { - - /* get statePtr lock */ - tsdPtr = TclThreadDataKeyGet(&dataKey); - WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - - /* Check for connect event */ - if (statePtr->readyEvents & FD_CONNECT) { - - /* Consume the connect event */ - statePtr->readyEvents &= ~(FD_CONNECT); - - /* - * For blocking sockets and foreground processing - * disable async connect as we continue now synchoneously - */ - if ( errorCodePtr != NULL && - ! (statePtr->flags & TCP_NONBLOCKING) ) { - CLEAR_BITS(statePtr->flags, TCP_ASYNC_CONNECT); - } - - /* Free list lock */ - SetEvent(tsdPtr->socketListLock); - - /* - * Continue connect. - * If switched to synchroneous connect, the connect is terminated. - */ - result = TcpConnect(NULL, statePtr); - - /* Restore event service mode */ - (void) Tcl_SetServiceMode(oldMode); - - /* - * Check for Succesfull connect or async connect restart - */ - - if (result == TCL_OK) { - /* - * Check for async connect restart - * (not possible for foreground blocking operation) - */ - if ( statePtr->flags & TCP_ASYNC_PENDING ) { - if (errorCodePtr != NULL) { - *errorCodePtr = EWOULDBLOCK; - } - return -1; - } - return 0; - } - - /* - * Connect finally failed. - * For foreground operation return ENOTCONN. - */ - - if (errorCodePtr != NULL) { - *errorCodePtr = ENOTCONN; - } - return -1; - } - - /* Free list lock */ - SetEvent(tsdPtr->socketListLock); - - /* - * Background operation returns with no action as there was no connect - * event - */ - - if ( errorCodePtr == NULL ) { - return -1; - } - - /* - * A non blocking socket waiting for an asyncronous connect - * returns directly the error EWOULDBLOCK - */ - - if (statePtr->flags & TCP_NONBLOCKING) { - *errorCodePtr = EWOULDBLOCK; - return -1; + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + for (infoPtr = tsdPtr->socketList; infoPtr != NULL; + infoPtr = infoPtr->nextPtr) { + if ((infoPtr->readyEvents & infoPtr->watchEvents) + && !(infoPtr->flags & SOCKET_PENDING)) { + infoPtr->flags |= SOCKET_PENDING; + evPtr = (SocketEvent *) ckalloc(sizeof(SocketEvent)); + evPtr->header.proc = SocketEventProc; + evPtr->socket = infoPtr->socket; + Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); } - - /* - * Wait until something happens. - */ - - WaitForSingleObject(tsdPtr->readyEvent, INFINITE); } + SetEvent(tsdPtr->socketListLock); } /* *---------------------------------------------------------------------- * - * TcpInputProc -- + * SocketEventProc -- * - * This function is invoked by the generic IO level to read input from a - * TCP socket based channel. + * This function is called by Tcl_ServiceEvent when a socket event + * reaches the front of the event queue. This function is responsible for + * notifying the generic channel code. * * Results: - * The number of bytes read is returned or -1 on error. An output - * argument contains the POSIX error code on error, or zero if no error - * occurred. + * Returns 1 if the event was handled, meaning it should be removed from + * the queue. Returns 0 if the event was not handled, meaning it should + * stay on the queue. The only time the event isn't handled is if the + * TCL_FILE_EVENTS flag bit isn't set. * * Side effects: - * Reads input from the input device of the channel. + * Whatever the channel callback functions do. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int -TcpInputProc( - ClientData instanceData, /* Socket state. */ - char *buf, /* Where to store data read. */ - int bufSize, /* How much space is available in the - * buffer? */ - int *errorCodePtr) /* Where to store error code. */ +SocketEventProc( + Tcl_Event *evPtr, /* Event to service. */ + int flags) /* Flags that indicate what events to handle, + * such as TCL_FILE_EVENTS. */ { - TcpState *statePtr = instanceData; - int bytesRead; - DWORD error; - ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + SocketInfo *infoPtr; + SocketEvent *eventPtr = (SocketEvent *) evPtr; + int mask = 0; + int events; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - *errorCodePtr = 0; + if (!(flags & TCL_FILE_EVENTS)) { + return 0; + } /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. + * Find the specified socket on the socket list. */ - if (!SocketsEnabled()) { - *errorCodePtr = EFAULT; - return -1; + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + for (infoPtr = tsdPtr->socketList; infoPtr != NULL; + infoPtr = infoPtr->nextPtr) { + if (infoPtr->socket == eventPtr->socket) { + break; + } } + SetEvent(tsdPtr->socketListLock); /* - * First check to see if EOF was already detected, to prevent calling the - * socket stack after the first time EOF is detected. + * Discard events that have gone stale. */ - if (statePtr->flags & SOCKET_EOF) { - return 0; + if (!infoPtr) { + return 1; } + infoPtr->flags &= ~SOCKET_PENDING; + /* - * Check if there is an async connect running. - * For blocking sockets terminate connect, otherwise do one step. - * For a non blocking socket return EWOULDBLOCK if connect not terminated + * Handle connection requests directly. */ - if (WaitForConnect(statePtr, errorCodePtr) != 0) { - return -1; + if (infoPtr->readyEvents & FD_ACCEPT) { + TcpAccept(infoPtr); + return 1; } /* - * No EOF, and it is connected, so try to read more from the socket. Note - * that we clear the FD_READ bit because read events are level triggered - * so a new event will be generated if there is still data available to be - * read. We have to simulate blocking behavior here since we are always - * using non-blocking sockets. + * Mask off unwanted events and compute the read/write mask so we can + * notify the channel. */ - while (1) { - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) UNSELECT, (LPARAM) statePtr); - /* single fd operation: this proc is only called for a connected socket. */ - bytesRead = recv(statePtr->sockets->fd, buf, bufSize, 0); - statePtr->readyEvents &= ~(FD_READ); + events = infoPtr->readyEvents & infoPtr->watchEvents; + if (events & FD_CLOSE) { /* - * Check for end-of-file condition or successful read. + * If the socket was closed and the channel is still interested in + * read events, then we need to ensure that we keep polling for this + * event until someone does something with the channel. Note that we + * do this before calling Tcl_NotifyChannel so we don't have to watch + * out for the channel being deleted out from under us. This may cause + * a redundant trip through the event loop, but it's simpler than + * trying to do unwind protection. */ - if (bytesRead == 0) { - statePtr->flags |= SOCKET_EOF; - } - if (bytesRead != SOCKET_ERROR) { - break; - } - + Tcl_Time blockTime = { 0, 0 }; + Tcl_SetMaxBlockTime(&blockTime); + mask |= TCL_READABLE|TCL_WRITABLE; + } else if (events & FD_READ) { /* - * If an error occurs after the FD_CLOSE has arrived, then ignore the - * error and report an EOF. + * Throw the readable event if an async connect failed. */ - if (statePtr->readyEvents & FD_CLOSE) { - statePtr->flags |= SOCKET_EOF; - bytesRead = 0; - break; - } + if (infoPtr->lastError) { - error = WSAGetLastError(); + mask |= TCL_READABLE; + + } else { + fd_set readFds; + struct timeval timeout; - /* - * If an RST comes, then ignore the error and report an EOF just like - * on unix. - */ + /* + * We must check to see if data is really available, since someone + * could have consumed the data in the meantime. Turn off async + * notification so select will work correctly. If the socket is still + * readable, notify the channel driver, otherwise reset the async + * select handler and keep waiting. + */ - if (error == WSAECONNRESET) { - statePtr->flags |= SOCKET_EOF; - bytesRead = 0; - break; - } + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, + (WPARAM) UNSELECT, (LPARAM) infoPtr); - /* - * Check for error condition or underflow in non-blocking case. - */ + FD_ZERO(&readFds); + FD_SET(infoPtr->socket, &readFds); + timeout.tv_usec = 0; + timeout.tv_sec = 0; - if ((statePtr->flags & TCP_NONBLOCKING) || (error != WSAEWOULDBLOCK)) { - TclWinConvertError(error); - *errorCodePtr = Tcl_GetErrno(); - bytesRead = -1; - break; + if (select(0, &readFds, NULL, NULL, &timeout) != 0) { + mask |= TCL_READABLE; + } else { + infoPtr->readyEvents &= ~(FD_READ); + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, + (WPARAM) SELECT, (LPARAM) infoPtr); + } } + } - /* - * In the blocking case, wait until the file becomes readable or - * closed and try again. - */ + /* + * writable event + */ - if (!WaitForSocketEvent(statePtr, FD_READ|FD_CLOSE, errorCodePtr)) { - bytesRead = -1; - break; - } + if (events & FD_WRITE) { + mask |= TCL_WRITABLE; } - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)statePtr); - - return bytesRead; + if (mask) { + Tcl_NotifyChannel(infoPtr->channel, mask); + } + return 1; } /* *---------------------------------------------------------------------- * - * TcpOutputProc -- + * TcpBlockProc -- * - * This function is called by the generic IO level to write data to a - * socket based channel. + * Sets a socket into blocking or non-blocking mode. * * Results: - * The number of bytes written or -1 on failure. + * 0 if successful, errno if there was an error. * * Side effects: - * Produces output on the socket. + * None. * *---------------------------------------------------------------------- */ static int -TcpOutputProc( - ClientData instanceData, /* Socket state. */ - const char *buf, /* The data buffer. */ - int toWrite, /* How many bytes to write? */ - int *errorCodePtr) /* Where to store error code. */ +TcpBlockProc( + ClientData instanceData, /* The socket to block/un-block. */ + int mode) /* TCL_MODE_BLOCKING or + * TCL_MODE_NONBLOCKING. */ { - TcpState *statePtr = instanceData; - int written; - DWORD error; - ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); - - *errorCodePtr = 0; - - /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ + SocketInfo *infoPtr = (SocketInfo *) instanceData; - if (!SocketsEnabled()) { - *errorCodePtr = EFAULT; - return -1; - } - - /* - * Check if there is an async connect running. - * For blocking sockets terminate connect, otherwise do one step. - * For a non blocking socket return EWOULDBLOCK if connect not terminated - */ - - if (WaitForConnect(statePtr, errorCodePtr) != 0) { - return -1; - } - - while (1) { - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) UNSELECT, (LPARAM) statePtr); - - /* single fd operation: this proc is only called for a connected socket. */ - written = send(statePtr->sockets->fd, buf, toWrite, 0); - if (written != SOCKET_ERROR) { - /* - * Since Windows won't generate a new write event until we hit an - * overflow condition, we need to force the event loop to poll - * until the condition changes. - */ - - if (statePtr->watchEvents & FD_WRITE) { - Tcl_Time blockTime = { 0, 0 }; - Tcl_SetMaxBlockTime(&blockTime); - } - break; - } - - /* - * Check for error condition or overflow. In the event of overflow, we - * need to clear the FD_WRITE flag so we can detect the next writable - * event. Note that Windows only sends a new writable event after a - * send fails with WSAEWOULDBLOCK. - */ - - error = WSAGetLastError(); - if (error == WSAEWOULDBLOCK) { - statePtr->readyEvents &= ~(FD_WRITE); - if (statePtr->flags & TCP_NONBLOCKING) { - *errorCodePtr = EWOULDBLOCK; - written = -1; - break; - } - } else { - TclWinConvertError(error); - *errorCodePtr = Tcl_GetErrno(); - written = -1; - break; - } - - /* - * In the blocking case, wait until the file becomes writable or - * closed and try again. - */ - - if (!WaitForSocketEvent(statePtr, FD_WRITE|FD_CLOSE, errorCodePtr)) { - written = -1; - break; - } + if (mode == TCL_MODE_NONBLOCKING) { + infoPtr->flags |= SOCKET_ASYNC; + } else { + infoPtr->flags &= ~(SOCKET_ASYNC); } - - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)statePtr); - - return written; + return 0; } /* @@ -979,7 +792,7 @@ TcpCloseProc( ClientData instanceData, /* The socket to close. */ Tcl_Interp *interp) /* Unused. */ { - TcpState *statePtr = instanceData; + SocketInfo *infoPtr = (SocketInfo *) instanceData; /* TIP #218 */ int errorCode = 0; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -997,37 +810,24 @@ TcpCloseProc( * background. */ - while ( statePtr->sockets != NULL ) { - TcpFdList *thisfd = statePtr->sockets; - statePtr->sockets = thisfd->next; - - if (closesocket(thisfd->fd) == SOCKET_ERROR) { - TclWinConvertError((DWORD) WSAGetLastError()); - errorCode = Tcl_GetErrno(); - } - ckfree(thisfd); + if (closesocket(infoPtr->socket) == SOCKET_ERROR) { + TclWinConvertWSAError((DWORD) WSAGetLastError()); + errorCode = Tcl_GetErrno(); } } - if (statePtr->addrlist != NULL) { - freeaddrinfo(statePtr->addrlist); - } - if (statePtr->myaddrlist != NULL) { - freeaddrinfo(statePtr->myaddrlist); - } - /* * Clear an eventual tsd info list pointer. * This may be called, if an async socket connect fails or is closed * between connect and thread action callback. */ - if (tsdPtr->pendingTcpState != NULL - && tsdPtr->pendingTcpState == statePtr) { + if (tsdPtr->pendingSocketInfo != NULL + && tsdPtr->pendingSocketInfo == infoPtr) { /* get infoPtr lock, because this concerns the notifier thread */ WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - tsdPtr->pendingTcpState = NULL; + tsdPtr->pendingSocketInfo = NULL; /* Free list lock */ SetEvent(tsdPtr->socketListLock); @@ -1040,93 +840,92 @@ TcpCloseProc( * fear of damaging the list. */ - ckfree(statePtr); + ckfree((char *) infoPtr); return errorCode; } /* *---------------------------------------------------------------------- * - * TcpClose2Proc -- + * NewSocketInfo -- * - * 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. + * This function allocates and initializes a new SocketInfo structure. * * Results: - * 0 if successful, the value of errno if failed. + * Returns a newly allocated SocketInfo. * * Side effects: - * Shuts down one side of the socket. + * None, except for allocation of memory. * *---------------------------------------------------------------------- */ -static int -TcpClose2Proc( - ClientData instanceData, /* The socket to close. */ - Tcl_Interp *interp, /* For error reporting. */ - int flags) /* Flags that indicate which side to close. */ +static SocketInfo * +NewSocketInfo( + SOCKET socket) { - TcpState *statePtr = instanceData; - int errorCode = 0; - int sd; + SocketInfo *infoPtr; + /* ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); */ + + infoPtr = (SocketInfo *) ckalloc((unsigned) sizeof(SocketInfo)); + infoPtr->channel = 0; + infoPtr->socket = socket; + infoPtr->flags = 0; + infoPtr->watchEvents = 0; + infoPtr->readyEvents = 0; + infoPtr->selectEvents = 0; + infoPtr->acceptEventCount = 0; + infoPtr->acceptProc = NULL; + infoPtr->acceptProcData = NULL; + infoPtr->lastError = 0; /* - * Shutdown the OS socket handle. + * TIP #218. Removed the code inserting the new structure into the global + * list. This is now handled in the thread action callbacks, and only + * there. */ - switch(flags) { - case TCL_CLOSE_READ: - sd = SD_RECEIVE; - break; - case TCL_CLOSE_WRITE: - sd = SD_SEND; - break; - default: - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "socket close2proc called bidirectionally", -1)); - } - return TCL_ERROR; - } - - /* single fd operation: Tcl_OpenTcpServer() does not set TCL_READABLE or - * TCL_WRITABLE so this should never be called for a server socket. */ - if (shutdown(statePtr->sockets->fd, sd) == SOCKET_ERROR) { - TclWinConvertError((DWORD) WSAGetLastError()); - errorCode = Tcl_GetErrno(); - } + infoPtr->nextPtr = NULL; - return errorCode; + return infoPtr; } /* *---------------------------------------------------------------------- * - * TcpSetOptionProc -- + * CreateSocket -- * - * Sets Tcp channel specific options. + * This function opens a new socket and initializes the SocketInfo + * structure. * * Results: - * None, unless an error happens. + * Returns a new SocketInfo, or NULL with an error in interp. * * Side effects: - * Changes attributes of the socket at the system level. + * None, except for allocation of memory. * *---------------------------------------------------------------------- */ -static int -TcpSetOptionProc( - ClientData instanceData, /* Socket state. */ - Tcl_Interp *interp, /* For error reporting - can be NULL. */ - const char *optionName, /* Name of the option to set. */ - const char *value) /* New value for option. */ +static SocketInfo * +CreateSocket( + Tcl_Interp *interp, /* For error reporting; can be NULL. */ + int port, /* Port number to open. */ + const char *host, /* Name of host on which to open port. */ + int server, /* 1 if socket should be a server socket, else + * 0 for a client socket. */ + const char *myaddr, /* Optional client-side address */ + int myport, /* Optional client-side port */ + int async) /* If nonzero, connect client socket + * asynchronously. */ { -#ifdef TCL_FEATURE_KEEPALIVE_NAGLE - TcpState *statePtr = instanceData; - SOCKET sock; -#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/ + u_long flag = 1; /* Indicates nonblocking mode. */ + SOCKADDR_IN sockaddr; /* Socket address */ + SOCKADDR_IN mysockaddr; /* Socket address for client */ + SOCKET sock = INVALID_SOCKET; + SocketInfo *infoPtr=NULL; /* The returned value. */ + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) + TclThreadDataKeyGet(&dataKey); /* * Check that WinSock is initialized; do not call it if not, to prevent @@ -1135,748 +934,345 @@ TcpSetOptionProc( */ if (!SocketsEnabled()) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "winsock is not initialized", -1)); - } - return TCL_ERROR; + return NULL; } -#ifdef TCL_FEATURE_KEEPALIVE_NAGLE - #error "TCL_FEATURE_KEEPALIVE_NAGLE not reviewed for whether to treat statePtr->sockets as single fd or list" - sock = statePtr->sockets->fd; - - if (!strcasecmp(optionName, "-keepalive")) { - BOOL val = FALSE; - int boolVar, rtn; - - if (Tcl_GetBoolean(interp, value, &boolVar) != TCL_OK) { - return TCL_ERROR; - } - if (boolVar) { - val = TRUE; - } - rtn = setsockopt(sock, SOL_SOCKET, SO_KEEPALIVE, - (const char *) &val, sizeof(BOOL)); - if (rtn != 0) { - TclWinConvertError(WSAGetLastError()); - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't set socket option: %s", - Tcl_PosixError(interp))); - } - return TCL_ERROR; - } - return TCL_OK; - } else if (!strcasecmp(optionName, "-nagle")) { - BOOL val = FALSE; - int boolVar, rtn; - - if (Tcl_GetBoolean(interp, value, &boolVar) != TCL_OK) { - return TCL_ERROR; - } - if (!boolVar) { - val = TRUE; - } - rtn = setsockopt(sock, IPPROTO_TCP, TCP_NODELAY, - (const char *) &val, sizeof(BOOL)); - if (rtn != 0) { - TclWinConvertError(WSAGetLastError()); - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't set socket option: %s", - Tcl_PosixError(interp))); - } - return TCL_ERROR; - } - return TCL_OK; + if (!CreateSocketAddress(&sockaddr, host, port)) { + goto error; + } + if ((myaddr != NULL || myport != 0) && + !CreateSocketAddress(&mysockaddr, myaddr, myport)) { + goto error; } - return Tcl_BadChannelOption(interp, optionName, "keepalive nagle"); -#else - return Tcl_BadChannelOption(interp, optionName, ""); -#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/ -} - -/* - *---------------------------------------------------------------------- - * - * TcpGetOptionProc -- - * - * Computes an option value for a TCP socket based channel, or a list of - * all options and their values. - * - * Note: This code is based on code contributed by John Haxby. - * - * Results: - * A standard Tcl result. The value of the specified option or a list of - * all options and their values is returned in the supplied DString. Sets - * Error message if needed. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TcpGetOptionProc( - ClientData instanceData, /* Socket state. */ - Tcl_Interp *interp, /* For error reporting - can be NULL. */ - const char *optionName, /* Name of the option to retrieve the value - * for, or NULL to get all options and their - * values. */ - Tcl_DString *dsPtr) /* Where to store the computed value; - * initialized by caller. */ -{ - TcpState *statePtr = instanceData; - char host[NI_MAXHOST], port[NI_MAXSERV]; - SOCKET sock; - size_t len = 0; - int reverseDNS = 0; -#define SUPPRESS_RDNS_VAR "::tcl::unsupported::noReverseDNS" + sock = socket(AF_INET, SOCK_STREAM, 0); + if (sock == INVALID_SOCKET) { + goto error; + } /* - * 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. + * Win-NT has a misfeature that sockets are inherited in child processes + * by default. Turn off the inherit bit. */ - if (!SocketsEnabled()) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "winsock is not initialized", -1)); - } - return TCL_ERROR; - } + SetHandleInformation((HANDLE) sock, HANDLE_FLAG_INHERIT, 0); /* - * Go one step in async connect - * If any error is thrown save it as backround error to report eventually below + * Set kernel space buffering */ - WaitForConnect(statePtr, NULL); - sock = statePtr->sockets->fd; - if (optionName != NULL) { - len = strlen(optionName); - } + TclSockMinimumBuffers((void *)sock, TCP_BUFFER_SIZE); - if ((len > 1) && (optionName[1] == 'e') && - (strncmp(optionName, "-error", len) == 0)) { + if (server) { + /* + * Bind to the specified port. Note that we must not call setsockopt + * with SO_REUSEADDR because Microsoft allows addresses to be reused + * even if they are still in use. + * + * Bind should not be affected by the socket having already been set + * into nonblocking mode. If there is trouble, this is one place to + * look for bugs. + */ + + if (bind(sock, (SOCKADDR *) &sockaddr, sizeof(SOCKADDR_IN)) + == SOCKET_ERROR) { + goto error; + } /* - * Do not return any errors if async connect is running - */ - if ( ! (statePtr->flags & TCP_ASYNC_PENDING) ) { + * 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 ( statePtr->flags & TCP_ASYNC_FAILED ) { + /* + * Add this socket to the global list of sockets. + */ - /* - * In case of a failed async connect, eventually report the - * connect error only once. - * Do not report the system error, as this comes again and again. - */ + infoPtr = NewSocketInfo(sock); - if ( statePtr->connectError != 0 ) { - Tcl_DStringAppend(dsPtr, - Tcl_ErrnoMsg(statePtr->connectError), -1); - statePtr->connectError = 0; - } + /* + * Set up the select mask for connection request events. + */ - } else { + infoPtr->selectEvents = FD_ACCEPT; + infoPtr->watchEvents |= FD_ACCEPT; - /* - * Report an eventual last error of the socket system - */ + /* + * Register for interest in events in the select mask. Note that this + * automatically places the socket into non-blocking mode. + */ + + ioctlsocket(sock, (long) FIONBIO, &flag); + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, + (LPARAM) infoPtr); - int optlen; - int ret; - DWORD err; + } else { + /* + * Try to bind to a local port, if specified. + */ - /* - * Populater the err Variable with a possix error - */ - optlen = sizeof(int); - ret = getsockopt(sock, SOL_SOCKET, SO_ERROR, - (char *)&err, &optlen); - /* - * The error was not returned directly but should be - * taken from WSA - */ - if (ret == SOCKET_ERROR) { - err = WSAGetLastError(); - } - /* - * Return error message - */ - if (err) { - TclWinConvertError(err); - Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(Tcl_GetErrno()), -1); - } + if (myaddr != NULL || myport != 0) { + if (bind(sock, (SOCKADDR *) &mysockaddr, sizeof(SOCKADDR_IN)) + == SOCKET_ERROR) { + goto error; } } - return TCL_OK; - } - if ((len > 1) && (optionName[1] == 'c') && - (strncmp(optionName, "-connecting", len) == 0)) { + /* + * Allocate socket info structure + */ - Tcl_DStringAppend(dsPtr, - (statePtr->flags & TCP_ASYNC_PENDING) - ? "1" : "0", -1); - return TCL_OK; - } + infoPtr = NewSocketInfo(sock); - if (interp != NULL && Tcl_GetVar(interp, SUPPRESS_RDNS_VAR, 0) != NULL) { - reverseDNS = NI_NUMERICHOST; - } + /* + * Set the socket into nonblocking mode if the connect should be done + * in the background. Activate connect notification. + */ - if ((len == 0) || ((len > 1) && (optionName[1] == 'p') && - (strncmp(optionName, "-peername", len) == 0))) { - address peername; - socklen_t size = sizeof(peername); + if (async) { + + /* get infoPtr lock */ + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - if ( (statePtr->flags & TCP_ASYNC_PENDING) ) { /* - * In async connect output an empty string + * Buffer new infoPtr in the tsd memory as long as it is not in + * the info list. This allows the event procedure to process the + * event. + * Bugfig for 336441ed59 to not ignore notifications until the + * infoPtr is in the list.. */ - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-peername"); - Tcl_DStringAppendElement(dsPtr, ""); - } else { - return TCL_OK; - } - } else if ( getpeername(sock, (LPSOCKADDR) &(peername.sa), &size) == 0) { + + tsdPtr->pendingSocketInfo = infoPtr; + /* - * Peername fetch succeeded - output list + * Set connect mask to connect events + * This is activated by a SOCKET_SELECT message to the notifier + * thread. */ - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-peername"); - Tcl_DStringStartSublist(dsPtr); - } - getnameinfo(&(peername.sa), size, host, sizeof(host), - NULL, 0, NI_NUMERICHOST); - Tcl_DStringAppendElement(dsPtr, host); - getnameinfo(&(peername.sa), size, host, sizeof(host), - port, sizeof(port), reverseDNS | NI_NUMERICSERV); - Tcl_DStringAppendElement(dsPtr, host); - Tcl_DStringAppendElement(dsPtr, port); - if (len == 0) { - Tcl_DStringEndSublist(dsPtr); - } else { - return TCL_OK; - } - } else { + infoPtr->selectEvents |= FD_CONNECT | FD_READ | FD_WRITE | FD_CLOSE; + infoPtr->flags |= SOCKET_ASYNC_CONNECT; + /* - * getpeername failed - but if we were asked for all the options - * (len==0), don't flag an error at that point because it could be - * an fconfigure request on a server socket (such sockets have no - * peer). {Copied from unix/tclUnixChan.c} + * Free list lock */ + SetEvent(tsdPtr->socketListLock); + + /* + * Activate accept notification and put in async mode + * Bug 336441ed59: activate notification before connect + * so we do not miss a notification of a fialed connect. + */ + ioctlsocket(sock, (long) FIONBIO, &flag); + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, + (LPARAM) infoPtr); - if (len) { - TclWinConvertError((DWORD) WSAGetLastError()); - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't get peername: %s", - Tcl_PosixError(interp))); - } - return TCL_ERROR; - } } - } - if ((len == 0) || ((len > 1) && (optionName[1] == 's') && - (strncmp(optionName, "-sockname", len) == 0))) { - TcpFdList *fds; - address sockname; - socklen_t size; - int found = 0; + /* + * Attempt to connect to the remote socket. + */ + + if (connect(sock, (SOCKADDR *) &sockaddr, + sizeof(SOCKADDR_IN)) == SOCKET_ERROR) { + TclWinConvertWSAError((DWORD) WSAGetLastError()); + if (Tcl_GetErrno() != EWOULDBLOCK) { + goto error; + } - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-sockname"); - Tcl_DStringStartSublist(dsPtr); - } - if ( (statePtr->flags & TCP_ASYNC_PENDING ) ) { /* - * In async connect output an empty string + * The connection is progressing in the background. */ - found = 1; + } else { - for (fds = statePtr->sockets; fds != NULL; fds = fds->next) { - sock = fds->fd; - size = sizeof(sockname); - if (getsockname(sock, &(sockname.sa), &size) >= 0) { - int flags = reverseDNS; - found = 1; - getnameinfo(&sockname.sa, size, host, sizeof(host), - NULL, 0, NI_NUMERICHOST); - Tcl_DStringAppendElement(dsPtr, host); + /* + * Set up the select mask for read/write events. If the connect + * attempt has not completed, include connect events. + */ - /* - * We don't want to resolve INADDR_ANY and sin6addr_any; they - * can sometimes cause problems (and never have a name). - */ - flags |= NI_NUMERICSERV; - if (sockname.sa.sa_family == AF_INET) { - if (sockname.sa4.sin_addr.s_addr == INADDR_ANY) { - flags |= NI_NUMERICHOST; - } - } else if (sockname.sa.sa_family == AF_INET6) { - if ((IN6_ARE_ADDR_EQUAL(&sockname.sa6.sin6_addr, - &in6addr_any)) || - (IN6_IS_ADDR_V4MAPPED(&sockname.sa6.sin6_addr) - && sockname.sa6.sin6_addr.s6_addr[12] == 0 - && sockname.sa6.sin6_addr.s6_addr[13] == 0 - && sockname.sa6.sin6_addr.s6_addr[14] == 0 - && sockname.sa6.sin6_addr.s6_addr[15] == 0)) { - flags |= NI_NUMERICHOST; - } - } - getnameinfo(&sockname.sa, size, host, sizeof(host), - port, sizeof(port), flags); - Tcl_DStringAppendElement(dsPtr, host); - Tcl_DStringAppendElement(dsPtr, port); - } - } - } - if (found) { - if (len) { - return TCL_OK; - } - Tcl_DStringEndSublist(dsPtr); - } else { - if (interp) { - TclWinConvertError((DWORD) WSAGetLastError()); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "can't get sockname: %s", Tcl_PosixError(interp))); - } - return TCL_ERROR; - } - } + infoPtr->selectEvents = FD_READ | FD_WRITE | FD_CLOSE; -#ifdef TCL_FEATURE_KEEPALIVE_NAGLE - if (len == 0 || !strncmp(optionName, "-keepalive", len)) { - int optlen; - BOOL opt = FALSE; + /* + * Register for interest in events in the select mask. Note that this + * automatically places the socket into non-blocking mode. + */ - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-keepalive"); - } - optlen = sizeof(BOOL); - getsockopt(sock, SOL_SOCKET, SO_KEEPALIVE, (char *)&opt, &optlen); - if (opt) { - Tcl_DStringAppendElement(dsPtr, "1"); - } else { - Tcl_DStringAppendElement(dsPtr, "0"); - } - if (len > 0) { - return TCL_OK; + ioctlsocket(sock, (long) FIONBIO, &flag); + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, + (LPARAM) infoPtr); } } - if (len == 0 || !strncmp(optionName, "-nagle", len)) { - int optlen; - BOOL opt = FALSE; + return infoPtr; - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-nagle"); - } - optlen = sizeof(BOOL); - getsockopt(sock, IPPROTO_TCP, TCP_NODELAY, (char *)&opt, &optlen); - if (opt) { - Tcl_DStringAppendElement(dsPtr, "0"); - } else { - Tcl_DStringAppendElement(dsPtr, "1"); - } - if (len > 0) { - return TCL_OK; - } + error: + TclWinConvertWSAError((DWORD) WSAGetLastError()); + if (interp != NULL) { + Tcl_AppendResult(interp, "couldn't open socket: ", + Tcl_PosixError(interp), NULL); } -#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/ - - if (len > 0) { -#ifdef TCL_FEATURE_KEEPALIVE_NAGLE - return Tcl_BadChannelOption(interp, optionName, - "connecting peername sockname keepalive nagle"); -#else - return Tcl_BadChannelOption(interp, optionName, "connecting peername sockname"); -#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/ + if (infoPtr != NULL) { + /* + * Free the allocated socket info structure and close the socket + */ + TcpCloseProc(infoPtr, interp); + } else if (sock != INVALID_SOCKET) { + /* + * No socket structure jet - just close + */ + closesocket(sock); } - - return TCL_OK; + return NULL; } /* *---------------------------------------------------------------------- * - * TcpWatchProc -- + * CreateSocketAddress -- * - * Informs the channel driver of the events that the generic channel code - * wishes to receive on this socket. + * This function initializes a sockaddr structure for a host and port. * * Results: - * None. + * 1 if the host was valid, 0 if the host could not be converted to an IP + * address. * * Side effects: - * May cause the notifier to poll if any of the specified conditions are - * already true. + * Fills in the *sockaddrPtr structure. * *---------------------------------------------------------------------- */ -static void -TcpWatchProc( - ClientData instanceData, /* The socket state. */ - int mask) /* Events of interest; an OR-ed combination of - * TCL_READABLE, TCL_WRITABLE and - * TCL_EXCEPTION. */ +static int +CreateSocketAddress( + LPSOCKADDR_IN sockaddrPtr, /* Socket address */ + const char *host, /* Host. NULL implies INADDR_ANY */ + int port) /* Port number */ { - TcpState *statePtr = instanceData; + struct hostent *hostent; /* Host database entry */ + struct in_addr addr; /* For 64/32 bit madness */ /* - * Update the watch events mask. Only if the socket is not a server - * socket. [Bug 557878] + * 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 (!statePtr->acceptProc) { - statePtr->watchEvents = 0; - if (mask & TCL_READABLE) { - statePtr->watchEvents |= (FD_READ|FD_CLOSE); - } - if (mask & TCL_WRITABLE) { - statePtr->watchEvents |= (FD_WRITE|FD_CLOSE); - } - - /* - * If there are any conditions already set, then tell the notifier to - * poll rather than block. - */ - - if (statePtr->readyEvents & statePtr->watchEvents) { - Tcl_Time blockTime = { 0, 0 }; + if (!SocketsEnabled()) { + Tcl_SetErrno(EFAULT); + return 0; + } - Tcl_SetMaxBlockTime(&blockTime); + 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. */ + } } } -} - -/* - *---------------------------------------------------------------------- - * - * TcpGetHandleProc -- - * - * Called from Tcl_GetChannelHandle to retrieve OS handles from inside a - * TCP socket based channel. - * - * Results: - * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if there is no - * handle for the specified direction. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - /* ARGSUSED */ -static int -TcpGetHandleProc( - ClientData instanceData, /* The socket state. */ - int direction, /* Not used. */ - ClientData *handlePtr) /* Where to store the handle. */ -{ - TcpState *statePtr = instanceData; + /* + * 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? + */ - *handlePtr = INT2PTR(statePtr->sockets->fd); - return TCL_OK; + sockaddrPtr->sin_addr.s_addr = addr.s_addr; + return 1; /* Success. */ } - - /* *---------------------------------------------------------------------- * - * TcpConnect -- - * - * This function opens a new socket in client mode. + * WaitForSocketEvent -- * - * This might be called in 3 circumstances: - * - By a regular socket command - * - By the event handler to continue an asynchroneous connect - * - By a blocking socket function (gets/puts) to terminate the - * connect synchroneously + * Waits until one of the specified events occurs on a socket. * * Results: - * TCL_OK, if the socket was successfully connected or an asynchronous - * connection is in progress. If an error occurs, TCL_ERROR is returned - * and an error message is left in interp. + * Returns 1 on success or 0 on failure, with an error code in + * errorCodePtr. * * Side effects: - * Opens a socket. - * - * Remarks: - * A single host name may resolve to more than one IP address, e.g. for - * an IPv4/IPv6 dual stack host. For handling asyncronously connecting - * sockets in the background for such hosts, this function can act as a - * coroutine. On the first call, it sets up the control variables for the - * two nested loops over the local and remote addresses. Once the first - * connection attempt is in progress, it sets up itself as a writable - * event handler for that socket, and returns. When the callback occurs, - * control is transferred to the "reenter" label, right after the initial - * return and the loops resume as if they had never been interrupted. - * For syncronously connecting sockets, the loops work the usual way. + * Processes socket events off the system queue. * *---------------------------------------------------------------------- */ static int -TcpConnect( - Tcl_Interp *interp, /* For error reporting; can be NULL. */ - TcpState *statePtr) +WaitForSocketEvent( + SocketInfo *infoPtr, /* Information about this socket. */ + int events, /* Events to look for. */ + int *errorCodePtr) /* Where to store errors? */ { - DWORD error; - /* - * We are started with async connect and the connect notification - * was not jet received - */ - int async_connect = statePtr->flags & TCP_ASYNC_CONNECT; - /* We were called by the event procedure and continue our loop */ - int async_callback = statePtr->flags & TCP_ASYNC_PENDING; - ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); - - if (async_callback) { - goto reenter; - } - - for (statePtr->addr = statePtr->addrlist; statePtr->addr != NULL; - statePtr->addr = statePtr->addr->ai_next) { - - for (statePtr->myaddr = statePtr->myaddrlist; statePtr->myaddr != NULL; - statePtr->myaddr = statePtr->myaddr->ai_next) { - - /* - * No need to try combinations of local and remote addresses - * of different families. - */ - - if (statePtr->myaddr->ai_family != statePtr->addr->ai_family) { - continue; - } - - /* - * Close the socket if it is still open from the last unsuccessful - * iteration. - */ - if (statePtr->sockets->fd != INVALID_SOCKET) { - closesocket(statePtr->sockets->fd); - } - - /* get statePtr lock */ - WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - - /* - * Reset last error from last try - */ - statePtr->notifierConnectError = 0; - Tcl_SetErrno(0); - - statePtr->sockets->fd = socket(statePtr->myaddr->ai_family, SOCK_STREAM, 0); - - /* Free list lock */ - SetEvent(tsdPtr->socketListLock); - - /* continue on socket creation error */ - if (statePtr->sockets->fd == INVALID_SOCKET) { - TclWinConvertError((DWORD) WSAGetLastError()); - continue; - } - - /* - * Win-NT has a misfeature that sockets are inherited in child - * processes by default. Turn off the inherit bit. - */ - - SetHandleInformation((HANDLE) statePtr->sockets->fd, HANDLE_FLAG_INHERIT, 0); - - /* - * Set kernel space buffering - */ - - TclSockMinimumBuffers((void *) statePtr->sockets->fd, TCP_BUFFER_SIZE); - - /* - * Try to bind to a local port. - */ - - if (bind(statePtr->sockets->fd, statePtr->myaddr->ai_addr, - statePtr->myaddr->ai_addrlen) == SOCKET_ERROR) { - TclWinConvertError((DWORD) WSAGetLastError()); - continue; - } - /* - * For asyncroneous connect set the socket in nonblocking mode - * and activate connect notification - */ - if (async_connect) { - TcpState *statePtr2; - int in_socket_list = 0; - /* get statePtr lock */ - WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - - /* - * Bugfig for 336441ed59 to not ignore notifications until the - * infoPtr is in the list. - * Check if my statePtr is already in the tsdPtr->socketList - * It is set after this call by TcpThreadActionProc and is set - * on a second round. - * - * If not, we buffer my statePtr in the tsd memory so it is not - * lost by the event procedure - */ - - for (statePtr2 = tsdPtr->socketList; statePtr2 != NULL; - statePtr2 = statePtr2->nextPtr) { - if (statePtr2 == statePtr) { - in_socket_list = 1; - break; - } - } - if (!in_socket_list) { - tsdPtr->pendingTcpState = statePtr; - } - /* - * Set connect mask to connect events - * This is activated by a SOCKET_SELECT message to the notifier - * thread. - */ - statePtr->selectEvents |= FD_CONNECT; - - /* - * Free list lock - */ - SetEvent(tsdPtr->socketListLock); - - /* activate accept notification */ - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, - (LPARAM) statePtr); - } - - /* - * Attempt to connect to the remote socket. - */ - - connect(statePtr->sockets->fd, statePtr->addr->ai_addr, - statePtr->addr->ai_addrlen); - - error = WSAGetLastError(); - TclWinConvertError(error); - - if (async_connect && error == WSAEWOULDBLOCK) { - /* - * Asynchroneous connect - */ - - /* - * Remember that we jump back behind this next round - */ - statePtr->flags |= TCP_ASYNC_PENDING; - return TCL_OK; - - reenter: - /* - * Re-entry point for async connect after connect event or - * blocking operation - * - * Clear the reenter flag - */ - statePtr->flags &= ~(TCP_ASYNC_PENDING); - /* get statePtr lock */ - WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - /* Get signaled connect error */ - TclWinConvertError((DWORD) statePtr->notifierConnectError); - /* Clear eventual connect flag */ - statePtr->selectEvents &= ~(FD_CONNECT); - /* Free list lock */ - SetEvent(tsdPtr->socketListLock); - } - - /* - * Clear the tsd socket list pointer if we did not wait for - * the FD_CONNECT asyncroneously - */ - tsdPtr->pendingTcpState = NULL; - - if (Tcl_GetErrno() == 0) { - goto out; - } - } - } + int result = 1; + int oldMode; + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) + TclThreadDataKeyGet(&dataKey); -out: /* - * Socket connected or connection failed + * Be sure to disable event servicing so we are truly modal. */ + oldMode = Tcl_SetServiceMode(TCL_SERVICE_NONE); + /* - * Async connect terminated + * Reset WSAAsyncSelect so we have a fresh set of events pending. + * Don't do that if we are waiting for a connect as we may miss + * a connect (bug 336441ed59). */ - CLEAR_BITS(statePtr->flags, TCP_ASYNC_CONNECT); - - if ( Tcl_GetErrno() == 0 ) { - /* - * Succesfully connected - */ - /* - * Set up the select mask for read/write events. - */ - statePtr->selectEvents = FD_READ | FD_WRITE | FD_CLOSE; + if ( 0 == (events & FD_CONNECT) ) { + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT, + (LPARAM) infoPtr); + + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, + (LPARAM) infoPtr); + } - /* - * Register for interest in events in the select mask. Note that this - * automatically places the socket into non-blocking mode. - */ + while (1) { + if (infoPtr->lastError) { + *errorCodePtr = infoPtr->lastError; + result = 0; + break; + } else if (infoPtr->readyEvents & events) { + break; + } else if (infoPtr->flags & SOCKET_ASYNC) { + *errorCodePtr = EWOULDBLOCK; + result = 0; + break; + } - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, - (LPARAM) statePtr); - } else { /* - * Connect failed + * Wait until something happens. */ - /* - * For async connect schedule a writable event to report the fail. - */ - if (async_callback) { - /* - * Set up the select mask for read/write events. - */ - statePtr->selectEvents = FD_WRITE|FD_READ; - /* get statePtr lock */ - WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - /* Signal ready readable and writable events */ - statePtr->readyEvents |= FD_WRITE | FD_READ; - /* Flag error to event routine */ - statePtr->flags |= TCP_ASYNC_FAILED; - /* Save connect error to be reported by 'fconfigure -error' */ - statePtr->connectError = Tcl_GetErrno(); - /* Free list lock */ - SetEvent(tsdPtr->socketListLock); - } - /* - * Error message on syncroneous connect - */ - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't open socket: %s", Tcl_PosixError(interp))); - } - return TCL_ERROR; + WaitForSingleObject(tsdPtr->readyEvent, INFINITE); } - return TCL_OK; + + (void) Tcl_SetServiceMode(oldMode); + return result; } /* @@ -1903,75 +1299,40 @@ Tcl_OpenTcpClient( const char *host, /* Host on which to open port. */ const char *myaddr, /* Client-side address */ int myport, /* Client-side port */ - int async) /* If nonzero, attempt to do an asynchronous - * connect. Otherwise we do a blocking - * connect. */ + int async) /* If nonzero, should connect client socket + * asynchronously. */ { - TcpState *statePtr; - const char *errorMsg = NULL; - struct addrinfo *addrlist = NULL, *myaddrlist = NULL; - char channelName[SOCK_CHAN_LENGTH]; + SocketInfo *infoPtr; + char channelName[16 + TCL_INTEGER_SPACE]; if (TclpHasSockets(interp) != TCL_OK) { return NULL; } /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. + * Create a new client socket and wrap it in a channel. */ - if (!SocketsEnabled()) { + infoPtr = CreateSocket(interp, port, host, 0, myaddr, myport, async); + if (infoPtr == NULL) { return NULL; } - /* - * Do the name lookups for the local and remote addresses. - */ + sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t)infoPtr->socket); - if (!TclCreateSocketAddress(interp, &addrlist, host, port, 0, &errorMsg) - || !TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1, - &errorMsg)) { - if (addrlist != NULL) { - freeaddrinfo(addrlist); - } - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't open socket: %s", errorMsg)); - } - return NULL; - } - - statePtr = NewSocketInfo(INVALID_SOCKET); - statePtr->addrlist = addrlist; - statePtr->myaddrlist = myaddrlist; - if (async) { - statePtr->flags |= TCP_ASYNC_CONNECT; - } - - /* - * Create a new client socket and wrap it in a channel. - */ - if (TcpConnect(interp, statePtr) != TCL_OK) { - TcpCloseProc(statePtr, NULL); - return NULL; + infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, + (ClientData) infoPtr, (TCL_READABLE | TCL_WRITABLE)); + if (Tcl_SetChannelOption(interp, infoPtr->channel, "-translation", + "auto crlf") == TCL_ERROR) { + Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel); + return (Tcl_Channel) NULL; } - - sprintf(channelName, SOCK_TEMPLATE, statePtr); - - statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, - statePtr, (TCL_READABLE | TCL_WRITABLE)); - if (TCL_ERROR == Tcl_SetChannelOption(NULL, statePtr->channel, - "-translation", "auto crlf")) { - Tcl_Close(NULL, statePtr->channel); - return NULL; - } else if (TCL_ERROR == Tcl_SetChannelOption(NULL, statePtr->channel, - "-eofchar", "")) { - Tcl_Close(NULL, statePtr->channel); - return NULL; + if (Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "") + == TCL_ERROR) { + Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel); + return (Tcl_Channel) NULL; } - return statePtr->channel; + return infoPtr->channel; } /* @@ -1987,6 +1348,8 @@ Tcl_OpenTcpClient( * Side effects: * None. * + * NOTE: Code contributed by Mark Diekhans (markd@grizzly.com) + * *---------------------------------------------------------------------- */ @@ -1994,15 +1357,15 @@ Tcl_Channel Tcl_MakeTcpClientChannel( ClientData sock) /* The socket to wrap up into a channel. */ { - TcpState *statePtr; - char channelName[SOCK_CHAN_LENGTH]; + SocketInfo *infoPtr; + char channelName[16 + TCL_INTEGER_SPACE]; ThreadSpecificData *tsdPtr; if (TclpHasSockets(NULL) != TCL_OK) { return NULL; } - tsdPtr = TclThreadDataKeyGet(&dataKey); + tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); /* * Set kernel space buffering and non-blocking. @@ -2010,20 +1373,21 @@ Tcl_MakeTcpClientChannel( TclSockMinimumBuffers(sock, TCP_BUFFER_SIZE); - statePtr = NewSocketInfo((SOCKET) sock); + infoPtr = NewSocketInfo((SOCKET) sock); /* * Start watching for read/write events on the socket. */ - statePtr->selectEvents = FD_READ | FD_CLOSE | FD_WRITE; - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)statePtr); + infoPtr->selectEvents = FD_READ | FD_CLOSE | FD_WRITE; + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, + (WPARAM) SELECT, (LPARAM) infoPtr); - sprintf(channelName, SOCK_TEMPLATE, statePtr); - statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, - statePtr, (TCL_READABLE | TCL_WRITABLE)); - Tcl_SetChannelOption(NULL, statePtr->channel, "-translation", "auto crlf"); - return statePtr->channel; + sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t)infoPtr->socket); + infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, + (ClientData) infoPtr, (TCL_READABLE | TCL_WRITABLE)); + Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto crlf"); + return infoPtr->channel; } /* @@ -2034,8 +1398,8 @@ Tcl_MakeTcpClientChannel( * Opens a TCP server socket and creates a channel around it. * * Results: - * The channel or NULL if failed. If an error occurred, an error message - * is left in the interp's result if interp is not NULL. + * The channel or NULL if failed. An error message is returned in the + * interpreter on failure. * * Side effects: * Opens a server socket and creates a new channel. @@ -2047,205 +1411,115 @@ Tcl_Channel Tcl_OpenTcpServer( Tcl_Interp *interp, /* For error reporting - may be NULL. */ int port, /* Port number to open. */ - const char *myHost, /* Name of local host. */ + const char *host, /* Name of local host. */ Tcl_TcpAcceptProc *acceptProc, /* Callback for accepting connections from new * clients. */ ClientData acceptProcData) /* Data for the callback. */ { - SOCKET sock = INVALID_SOCKET; - unsigned short chosenport = 0; - struct addrinfo *addrlist = NULL; - struct addrinfo *addrPtr; /* Socket address to listen on. */ - TcpState *statePtr = NULL; /* The returned value. */ - char channelName[SOCK_CHAN_LENGTH]; - u_long flag = 1; /* Indicates nonblocking mode. */ - const char *errorMsg = NULL; - ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + SocketInfo *infoPtr; + char channelName[16 + TCL_INTEGER_SPACE]; if (TclpHasSockets(interp) != TCL_OK) { return NULL; } /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. + * Create a new client socket and wrap it in a channel. */ - if (!SocketsEnabled()) { + infoPtr = CreateSocket(interp, port, host, 1, NULL, 0, 0); + if (infoPtr == NULL) { return NULL; } - /* - * Construct the addresses for each end of the socket. - */ - - if (!TclCreateSocketAddress(interp, &addrlist, myHost, port, 1, &errorMsg)) { - goto error; - } - - for (addrPtr = addrlist; addrPtr != NULL; addrPtr = addrPtr->ai_next) { - sock = socket(addrPtr->ai_family, addrPtr->ai_socktype, - addrPtr->ai_protocol); - if (sock == INVALID_SOCKET) { - TclWinConvertError((DWORD) WSAGetLastError()); - continue; - } - - /* - * Win-NT has a misfeature that sockets are inherited in child - * processes by default. Turn off the inherit bit. - */ - - SetHandleInformation((HANDLE) sock, HANDLE_FLAG_INHERIT, 0); - - /* - * Set kernel space buffering - */ - - TclSockMinimumBuffers((void *)sock, TCP_BUFFER_SIZE); - - /* - * Make sure we use the same port when opening two server sockets - * for IPv4 and IPv6. - * - * As sockaddr_in6 uses the same offset and size for the port - * member as sockaddr_in, we can handle both through the IPv4 API. - */ - - if (port == 0 && chosenport != 0) { - ((struct sockaddr_in *) addrPtr->ai_addr)->sin_port = - htons(chosenport); - } - - /* - * Bind to the specified port. Note that we must not call - * setsockopt with SO_REUSEADDR because Microsoft allows addresses - * to be reused even if they are still in use. - * - * Bind should not be affected by the socket having already been - * set into nonblocking mode. If there is trouble, this is one - * place to look for bugs. - */ - - if (bind(sock, addrPtr->ai_addr, addrPtr->ai_addrlen) - == SOCKET_ERROR) { - TclWinConvertError((DWORD) WSAGetLastError()); - closesocket(sock); - continue; - } - if (port == 0 && chosenport == 0) { - address sockname; - socklen_t namelen = sizeof(sockname); - - /* - * Synchronize port numbers when binding to port 0 of multiple - * addresses. - */ - - if (getsockname(sock, &sockname.sa, &namelen) >= 0) { - chosenport = ntohs(sockname.sa4.sin_port); - } - } - - /* - * Set the maximum number of pending connect requests to the max - * value allowed on each platform (Win32 and Win32s may be - * different, and there may be differences between TCP/IP stacks). - */ - - if (listen(sock, SOMAXCONN) == SOCKET_ERROR) { - TclWinConvertError((DWORD) WSAGetLastError()); - closesocket(sock); - continue; - } - - if (statePtr == NULL) { - /* - * Add this socket to the global list of sockets. - */ - statePtr = NewSocketInfo(sock); - } else { - AddSocketInfoFd( statePtr, sock ); - } - } - -error: - if (addrlist != NULL) { - freeaddrinfo(addrlist); - } - - if (statePtr != NULL) { - - statePtr->acceptProc = acceptProc; - statePtr->acceptProcData = acceptProcData; - sprintf(channelName, SOCK_TEMPLATE, statePtr); - statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, - statePtr, 0); - /* - * Set up the select mask for connection request events. - */ + infoPtr->acceptProc = acceptProc; + infoPtr->acceptProcData = acceptProcData; - statePtr->selectEvents = FD_ACCEPT; + sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t)infoPtr->socket); - /* - * Register for interest in events in the select mask. Note that this - * automatically places the socket into non-blocking mode. - */ - - ioctlsocket(sock, (long) FIONBIO, &flag); - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, - (LPARAM) statePtr); - if (Tcl_SetChannelOption(interp, statePtr->channel, "-eofchar", "") + infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, + (ClientData) infoPtr, 0); + if (Tcl_SetChannelOption(interp, infoPtr->channel, "-eofchar", "") == TCL_ERROR) { - Tcl_Close(NULL, statePtr->channel); - return NULL; - } - return statePtr->channel; - } - - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't open socket: %s", - (errorMsg ? errorMsg : Tcl_PosixError(interp)))); + Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel); + return (Tcl_Channel) NULL; } - if (sock != INVALID_SOCKET) { - closesocket(sock); - } - return NULL; + return infoPtr->channel; } /* *---------------------------------------------------------------------- * * TcpAccept -- - * Accept a TCP socket connection. This is called by the event loop. + * + * Accept a TCP socket connection. This is called by SocketEventProc and + * it in turns calls the registered accept function. * * Results: * None. * * Side effects: - * Creates a new connection socket. Calls the registered callback for the - * connection acceptance mechanism. + * Invokes the accept proc which may invoke arbitrary Tcl code. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ 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. */ { - TcpState *newInfoPtr; - TcpState *statePtr = fds->statePtr; - int len = sizeof(addr); - char channelName[SOCK_CHAN_LENGTH]; - char host[NI_MAXHOST], port[NI_MAXSERV]; - ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + SOCKET newSocket; + SocketInfo *newInfoPtr; + SOCKADDR_IN addr; + int len; + char channelName[16 + TCL_INTEGER_SPACE]; + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) + TclThreadDataKeyGet(&dataKey); + + /* + * Accept the incoming connection request. + */ + + len = sizeof(SOCKADDR_IN); + + newSocket = accept(infoPtr->socket, (SOCKADDR *)&addr, + &len); + + /* + * Protect access to sockets (acceptEventCount, readyEvents) in socketList + * by the lock. Fix for SF Tcl Bug 3056775. + */ + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + + /* + * Clear the ready mask so we can detect the next connection request. Note + * that connection requests are level triggered, so if there is a request + * already pending, a new event will be generated. + */ + + if (newSocket == INVALID_SOCKET) { + infoPtr->acceptEventCount = 0; + infoPtr->readyEvents &= ~(FD_ACCEPT); + + SetEvent(tsdPtr->socketListLock); + return; + } + + /* + * It is possible that more than one FD_ACCEPT has been sent, so an extra + * count must be kept. Decrement the count, and reset the readyEvent bit + * if the count is no longer > 0. + */ + + infoPtr->acceptEventCount--; + + if (infoPtr->acceptEventCount <= 0) { + infoPtr->readyEvents &= ~(FD_ACCEPT); + } + + SetEvent(tsdPtr->socketListLock); /* * Win-NT has a misfeature that sockets are inherited in child processes @@ -2255,7 +1529,7 @@ TcpAccept( SetHandleInformation((HANDLE) newSocket, HANDLE_FLAG_INHERIT, 0); /* - * Add this socket to the global list of sockets. + * Allocate socket info structure */ newInfoPtr = NewSocketInfo(newSocket); @@ -2265,20 +1539,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_TEMPLATE, newInfoPtr); + 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; } @@ -2286,683 +1560,647 @@ TcpAccept( * Invoke the accept callback function. */ - if (statePtr->acceptProc != NULL) { - getnameinfo(&(addr.sa), len, host, sizeof(host), port, sizeof(port), - NI_NUMERICHOST|NI_NUMERICSERV); - statePtr->acceptProc(statePtr->acceptProcData, newInfoPtr->channel, - host, atoi(port)); + if (infoPtr->acceptProc != NULL) { + (infoPtr->acceptProc) (infoPtr->acceptProcData, newInfoPtr->channel, + inet_ntoa(addr.sin_addr), ntohs(addr.sin_port)); } } /* *---------------------------------------------------------------------- * - * InitSockets -- - * - * Registers the event window for the socket notifier code. + * TcpInputProc -- * - * Assumes socketMutex is held. + * This function is called by the generic IO level to read data from a + * socket based channel. * * Results: - * None. + * The number of bytes read or -1 on error. * * Side effects: - * Register a new window class and creates a - * window for use in asynchronous socket notification. + * Consumes input from the socket. * *---------------------------------------------------------------------- */ -static void -InitSockets(void) +static int +TcpInputProc( + ClientData instanceData, /* The socket state. */ + char *buf, /* Where to store data. */ + int toRead, /* Maximum number of bytes to read. */ + int *errorCodePtr) /* Where to store error codes. */ { - DWORD id; - ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); - - if (!initialized) { - initialized = 1; - TclCreateLateExitHandler(SocketExitHandler, NULL); + SocketInfo *infoPtr = (SocketInfo *) instanceData; + int bytesRead; + DWORD error; + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) + TclThreadDataKeyGet(&dataKey); - /* - * Create the async notification window with a new class. We must - * create a new class to avoid a Windows 95 bug that causes us to get - * the wrong message number for socket events if the message window is - * a subclass of a static control. - */ + *errorCodePtr = 0; - windowClass.style = 0; - windowClass.cbClsExtra = 0; - windowClass.cbWndExtra = 0; - windowClass.hInstance = TclWinGetTclInstance(); - windowClass.hbrBackground = NULL; - windowClass.lpszMenuName = NULL; - windowClass.lpszClassName = classname; - windowClass.lpfnWndProc = SocketProc; - windowClass.hIcon = NULL; - windowClass.hCursor = NULL; + /* + * 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 (!RegisterClass(&windowClass)) { - TclWinConvertError(GetLastError()); - goto initFailure; - } + if (!SocketsEnabled()) { + *errorCodePtr = EFAULT; + return -1; } /* - * Check for per-thread initialization. + * First check to see if EOF was already detected, to prevent calling the + * socket stack after the first time EOF is detected. */ - if (tsdPtr != NULL) { - return; + if (infoPtr->flags & SOCKET_EOF) { + return 0; } /* - * 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. + * Check to see if the socket is connected before trying to read. */ - tsdPtr = TCL_TSD_INIT(&dataKey); - tsdPtr->pendingTcpState = NULL; - tsdPtr->socketList = NULL; - tsdPtr->hwnd = NULL; - tsdPtr->threadId = Tcl_GetCurrentThread(); - tsdPtr->readyEvent = CreateEvent(NULL, FALSE, FALSE, NULL); - if (tsdPtr->readyEvent == NULL) { - goto initFailure; - } - tsdPtr->socketListLock = CreateEvent(NULL, FALSE, TRUE, NULL); - if (tsdPtr->socketListLock == NULL) { - goto initFailure; - } - tsdPtr->socketThread = CreateThread(NULL, 256, SocketThread, tsdPtr, 0, - &id); - if (tsdPtr->socketThread == NULL) { - goto initFailure; + if ((infoPtr->flags & SOCKET_ASYNC_CONNECT) + && !WaitForSocketEvent(infoPtr, FD_CONNECT, errorCodePtr)) { + return -1; } - 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. + * No EOF, and it is connected, so try to read more from the socket. Note + * that we clear the FD_READ bit because read events are level triggered + * so a new event will be generated if there is still data available to be + * read. We have to simulate blocking behavior here since we are always + * using non-blocking sockets. */ - WaitForSingleObject(tsdPtr->readyEvent, INFINITE); + while (1) { + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, + (WPARAM) UNSELECT, (LPARAM) infoPtr); + bytesRead = recv(infoPtr->socket, buf, toRead, 0); + infoPtr->readyEvents &= ~(FD_READ); - if (tsdPtr->hwnd == NULL) { - goto initFailure; /* Trouble creating the window. */ + /* + * Check for end-of-file condition or successful read. + */ + + if (bytesRead == 0) { + infoPtr->flags |= SOCKET_EOF; + } + if (bytesRead != SOCKET_ERROR) { + break; + } + + /* + * If an error occurs after the FD_CLOSE has arrived, then ignore the + * error and report an EOF. + */ + + if (infoPtr->readyEvents & FD_CLOSE) { + infoPtr->flags |= SOCKET_EOF; + bytesRead = 0; + break; + } + + error = WSAGetLastError(); + + /* + * If an RST comes, then ignore the error and report an EOF just like + * on unix. + */ + + if (error == WSAECONNRESET) { + infoPtr->flags |= SOCKET_EOF; + bytesRead = 0; + break; + } + + /* + * Check for error condition or underflow in non-blocking case. + */ + + if ((infoPtr->flags & SOCKET_ASYNC) || (error != WSAEWOULDBLOCK)) { + TclWinConvertWSAError(error); + *errorCodePtr = Tcl_GetErrno(); + bytesRead = -1; + break; + } + + /* + * In the blocking case, wait until the file becomes readable or + * closed and try again. + */ + + if (!WaitForSocketEvent(infoPtr, FD_READ|FD_CLOSE, errorCodePtr)) { + bytesRead = -1; + break; + } } - Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL); - return; + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, + (WPARAM) SELECT, (LPARAM) infoPtr); - initFailure: - TclpFinalizeSockets(); - initialized = -1; - return; + return bytesRead; } /* *---------------------------------------------------------------------- * - * SocketsEnabled -- - * - * Check that the WinSock was successfully initialized. + * TcpOutputProc -- * - * Warning: - * This check was useful in times of Windows98 where WinSock may - * not be available. This is not the case any more. - * This function may be removed with TCL 9.0 + * This function is called by the generic IO level to write data to a + * socket based channel. * * Results: - * 1 if it is. + * The number of bytes written or -1 on failure. * * Side effects: - * None. + * Produces output on the socket. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ static int -SocketsEnabled(void) +TcpOutputProc( + ClientData instanceData, /* The socket state. */ + const char *buf, /* Where to get data. */ + int toWrite, /* Maximum number of bytes to write. */ + int *errorCodePtr) /* Where to store error codes. */ { - int enabled; + SocketInfo *infoPtr = (SocketInfo *) instanceData; + int bytesWritten; + DWORD error; + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) + TclThreadDataKeyGet(&dataKey); - Tcl_MutexLock(&socketMutex); - enabled = (initialized == 1); - Tcl_MutexUnlock(&socketMutex); - return enabled; -} + *errorCodePtr = 0; - -/* - *---------------------------------------------------------------------- - * - * SocketExitHandler -- - * - * Callback invoked during exit clean up to delete the socket - * communication window. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ + /* + * 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. + */ - /* ARGSUSED */ -static void -SocketExitHandler( - ClientData clientData) /* Not used. */ -{ - Tcl_MutexLock(&socketMutex); + if (!SocketsEnabled()) { + *errorCodePtr = EFAULT; + return -1; + } /* - * Make sure the socket event handling window is cleaned-up for, at - * most, this thread. + * Check to see if the socket is connected before trying to write. */ - TclpFinalizeSockets(); - UnregisterClass(classname, TclWinGetTclInstance()); - initialized = 0; - Tcl_MutexUnlock(&socketMutex); -} - -/* - *---------------------------------------------------------------------- - * - * SocketSetupProc -- - * - * This function is invoked before Tcl_DoOneEvent blocks waiting for an - * event. - * - * Results: - * None. - * - * Side effects: - * Adjusts the block time if needed. - * - *---------------------------------------------------------------------- - */ + if ((infoPtr->flags & SOCKET_ASYNC_CONNECT) + && !WaitForSocketEvent(infoPtr, FD_CONNECT, errorCodePtr)) { + return -1; + } -void -SocketSetupProc( - ClientData data, /* Not used. */ - int flags) /* Event flags as passed to Tcl_DoOneEvent. */ -{ - TcpState *statePtr; - Tcl_Time blockTime = { 0, 0 }; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + while (1) { + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, + (WPARAM) UNSELECT, (LPARAM) infoPtr); - if (!(flags & TCL_FILE_EVENTS)) { - return; - } + bytesWritten = send(infoPtr->socket, buf, toWrite, 0); + if (bytesWritten != SOCKET_ERROR) { + /* + * Since Windows won't generate a new write event until we hit an + * overflow condition, we need to force the event loop to poll + * until the condition changes. + */ - /* - * Check to see if there is a ready socket. If so, poll. - */ - WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - for (statePtr = tsdPtr->socketList; statePtr != NULL; - statePtr = statePtr->nextPtr) { - if (statePtr->readyEvents & - (statePtr->watchEvents | FD_CONNECT | FD_ACCEPT) - ) { - Tcl_SetMaxBlockTime(&blockTime); + if (infoPtr->watchEvents & FD_WRITE) { + Tcl_Time blockTime = { 0, 0 }; + Tcl_SetMaxBlockTime(&blockTime); + } + break; + } + + /* + * Check for error condition or overflow. In the event of overflow, we + * need to clear the FD_WRITE flag so we can detect the next writable + * event. Note that Windows only sends a new writable event after a + * send fails with WSAEWOULDBLOCK. + */ + + error = WSAGetLastError(); + if (error == WSAEWOULDBLOCK) { + infoPtr->readyEvents &= ~(FD_WRITE); + if (infoPtr->flags & SOCKET_ASYNC) { + *errorCodePtr = EWOULDBLOCK; + bytesWritten = -1; + break; + } + } else { + TclWinConvertWSAError(error); + *errorCodePtr = Tcl_GetErrno(); + bytesWritten = -1; + break; + } + + /* + * In the blocking case, wait until the file becomes writable or + * closed and try again. + */ + + if (!WaitForSocketEvent(infoPtr, FD_WRITE|FD_CLOSE, errorCodePtr)) { + bytesWritten = -1; break; } } - SetEvent(tsdPtr->socketListLock); + + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, + (WPARAM) SELECT, (LPARAM) infoPtr); + + return bytesWritten; } /* *---------------------------------------------------------------------- * - * SocketCheckProc -- + * TcpSetOptionProc -- * - * This function is called by Tcl_DoOneEvent to check the socket event - * source for events. + * Sets Tcp channel specific options. * * Results: - * None. + * None, unless an error happens. * * Side effects: - * May queue an event. + * Changes attributes of the socket at the system level. * *---------------------------------------------------------------------- */ -static void -SocketCheckProc( - ClientData data, /* Not used. */ - int flags) /* Event flags as passed to Tcl_DoOneEvent. */ +static int +TcpSetOptionProc( + ClientData instanceData, /* Socket state. */ + Tcl_Interp *interp, /* For error reporting - can be NULL. */ + const char *optionName, /* Name of the option to set. */ + const char *value) /* New value for option. */ { - TcpState *statePtr; - SocketEvent *evPtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - if (!(flags & TCL_FILE_EVENTS)) { - return; - } +#ifdef TCL_FEATURE_KEEPALIVE_NAGLE + SocketInfo *infoPtr; + SOCKET sock; +#endif /* - * Queue events for any ready sockets that don't already have events - * queued (caused by persistent states that won't generate WinSock - * events). + * Check that WinSock is initialized; do not call it if not, to prevent + * system crashes. This can happen at exit time if the exit handler for + * WinSock ran before other exit handlers that want to use sockets. */ - WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - for (statePtr = tsdPtr->socketList; statePtr != NULL; - statePtr = statePtr->nextPtr) { - if ((statePtr->readyEvents & - (statePtr->watchEvents | FD_CONNECT | FD_ACCEPT)) - && !(statePtr->flags & SOCKET_PENDING) - ) { - statePtr->flags |= SOCKET_PENDING; - evPtr = ckalloc(sizeof(SocketEvent)); - evPtr->header.proc = SocketEventProc; - evPtr->socket = statePtr->sockets->fd; - Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); + if (!SocketsEnabled()) { + if (interp) { + Tcl_AppendResult(interp, "winsock is not initialized", NULL); } + return TCL_ERROR; } - SetEvent(tsdPtr->socketListLock); + +#ifdef TCL_FEATURE_KEEPALIVE_NAGLE + infoPtr = (SocketInfo *) instanceData; + sock = infoPtr->socket; + + if (!strcasecmp(optionName, "-keepalive")) { + BOOL val = FALSE; + int boolVar, rtn; + + if (Tcl_GetBoolean(interp, value, &boolVar) != TCL_OK) { + return TCL_ERROR; + } + if (boolVar) { + val = TRUE; + } + rtn = setsockopt(sock, SOL_SOCKET, SO_KEEPALIVE, + (const char *) &val, sizeof(BOOL)); + if (rtn != 0) { + TclWinConvertWSAError(WSAGetLastError()); + if (interp) { + Tcl_AppendResult(interp, "couldn't set socket option: ", + Tcl_PosixError(interp), NULL); + } + return TCL_ERROR; + } + return TCL_OK; + } else if (!strcasecmp(optionName, "-nagle")) { + BOOL val = FALSE; + int boolVar, rtn; + + if (Tcl_GetBoolean(interp, value, &boolVar) != TCL_OK) { + return TCL_ERROR; + } + if (!boolVar) { + val = TRUE; + } + rtn = setsockopt(sock, IPPROTO_TCP, TCP_NODELAY, + (const char *) &val, sizeof(BOOL)); + if (rtn != 0) { + TclWinConvertWSAError(WSAGetLastError()); + if (interp) { + Tcl_AppendResult(interp, "couldn't set socket option: ", + Tcl_PosixError(interp), NULL); + } + return TCL_ERROR; + } + return TCL_OK; + } + + return Tcl_BadChannelOption(interp, optionName, "keepalive nagle"); +#else + return Tcl_BadChannelOption(interp, optionName, ""); +#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/ } /* *---------------------------------------------------------------------- * - * SocketEventProc -- + * TcpGetOptionProc -- * - * This function is called by Tcl_ServiceEvent when a socket event - * reaches the front of the event queue. This function is responsible for - * notifying the generic channel code. + * Computes an option value for a TCP socket based channel, or a list of + * all options and their values. + * + * Note: This code is based on code contributed by John Haxby. * * Results: - * Returns 1 if the event was handled, meaning it should be removed from - * the queue. Returns 0 if the event was not handled, meaning it should - * stay on the queue. The only time the event isn't handled is if the - * TCL_FILE_EVENTS flag bit isn't set. + * A standard Tcl result. The value of the specified option or a list of + * all options and their values is returned in the supplied DString. * * Side effects: - * Whatever the channel callback functions do. + * None. * *---------------------------------------------------------------------- */ static int -SocketEventProc( - Tcl_Event *evPtr, /* Event to service. */ - int flags) /* Flags that indicate what events to handle, - * such as TCL_FILE_EVENTS. */ +TcpGetOptionProc( + ClientData instanceData, /* Socket state. */ + Tcl_Interp *interp, /* For error reporting - can be NULL */ + const char *optionName, /* Name of the option to retrieve the value + * for, or NULL to get all options and their + * values. */ + Tcl_DString *dsPtr) /* Where to store the computed value; + * initialized by caller. */ { - TcpState *statePtr; - SocketEvent *eventPtr = (SocketEvent *) evPtr; - int mask = 0, events; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - TcpFdList *fds; - SOCKET newSocket; - address addr; - int len; - - if (!(flags & TCL_FILE_EVENTS)) { - return 0; - } + SocketInfo *infoPtr; + SOCKADDR_IN sockname; + SOCKADDR_IN peername; + struct hostent *hostEntPtr; + SOCKET sock; + int size = sizeof(SOCKADDR_IN); + size_t len = 0; + char buf[TCL_INTEGER_SPACE]; /* - * Find the specified socket on the socket list. + * Check that WinSock is initialized; do not call it if not, to prevent + * system crashes. This can happen at exit time if the exit handler for + * WinSock ran before other exit handlers that want to use sockets. */ - WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - for (statePtr = tsdPtr->socketList; statePtr != NULL; - statePtr = statePtr->nextPtr) { - if (statePtr->sockets->fd == eventPtr->socket) { - break; + if (!SocketsEnabled()) { + if (interp) { + Tcl_AppendResult(interp, "winsock is not initialized", NULL); } + return TCL_ERROR; } - /* - * Discard events that have gone stale. - */ - - if (!statePtr) { - SetEvent(tsdPtr->socketListLock); - return 1; + infoPtr = (SocketInfo *) instanceData; + sock = (int) infoPtr->socket; + if (optionName != NULL) { + len = strlen(optionName); } - /* - * Clear flag that (this) event is pending - */ - - statePtr->flags &= ~SOCKET_PENDING; - - /* - * Continue async connect if pending and ready - */ - - if ( statePtr->readyEvents & FD_CONNECT ) { - if ( statePtr->flags & TCP_ASYNC_PENDING ) { + if ((len > 1) && (optionName[1] == 'e') && + (strncmp(optionName, "-error", len) == 0)) { + int optlen; + DWORD err; + int ret; - /* - * Do one step and save eventual connect error - */ + optlen = sizeof(int); + ret = TclWinGetSockOpt((int)sock, SOL_SOCKET, SO_ERROR, + (char *)&err, &optlen); + if (ret == SOCKET_ERROR) { + err = WSAGetLastError(); + } + if (err) { + TclWinConvertWSAError(err); + Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(Tcl_GetErrno()), -1); + } + return TCL_OK; + } - SetEvent(tsdPtr->socketListLock); - WaitForConnect(statePtr,NULL); + if ((len == 0) || ((len > 1) && (optionName[1] == 'p') && + (strncmp(optionName, "-peername", len) == 0))) { + if (getpeername(sock, (LPSOCKADDR) &peername, &size) == 0) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-peername"); + Tcl_DStringStartSublist(dsPtr); + } + Tcl_DStringAppendElement(dsPtr, inet_ntoa(peername.sin_addr)); + if (peername.sin_addr.s_addr == 0) { + hostEntPtr = NULL; + } else { + hostEntPtr = gethostbyaddr((char *) &(peername.sin_addr), + sizeof(peername.sin_addr), AF_INET); + } + if (hostEntPtr != NULL) { + Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name); + } else { + Tcl_DStringAppendElement(dsPtr, inet_ntoa(peername.sin_addr)); + } + TclFormatInt(buf, ntohs(peername.sin_port)); + Tcl_DStringAppendElement(dsPtr, buf); + if (len == 0) { + Tcl_DStringEndSublist(dsPtr); + } else { + return TCL_OK; + } } else { - /* - * No async connect reenter pending. Just clear event. + * getpeername failed - but if we were asked for all the options + * (len==0), don't flag an error at that point because it could be + * an fconfigure request on a server socket (such sockets have no + * peer). {Copied from unix/tclUnixChan.c} */ - statePtr->readyEvents &= ~(FD_CONNECT); - SetEvent(tsdPtr->socketListLock); + if (len) { + TclWinConvertWSAError((DWORD) WSAGetLastError()); + if (interp) { + Tcl_AppendResult(interp, "can't get peername: ", + Tcl_PosixError(interp), NULL); + } + return TCL_ERROR; + } } - return 1; } - /* - * Handle connection requests directly. - */ - if (statePtr->readyEvents & FD_ACCEPT) { - for (fds = statePtr->sockets; fds != NULL; fds = fds->next) { - - /* - * Accept the incoming connection request. - */ - len = sizeof(address); - - newSocket = accept(fds->fd, &(addr.sa), &len); - - /* On Tcl server sockets with multiple OS fds we loop over the fds trying - * an accept() on each, so we expect INVALID_SOCKET. There are also other - * network stack conditions that can result in FD_ACCEPT but a subsequent - * failure on accept() by the time we get around to it. - * Access to sockets (acceptEventCount, readyEvents) in socketList - * is still protected by the lock (prevents reintroduction of - * SF Tcl Bug 3056775. - */ - - if (newSocket == INVALID_SOCKET) { - /* int err = WSAGetLastError(); */ - continue; + if ((len == 0) || ((len > 1) && (optionName[1] == 's') && + (strncmp(optionName, "-sockname", len) == 0))) { + if (getsockname(sock, (LPSOCKADDR) &sockname, &size) == 0) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-sockname"); + Tcl_DStringStartSublist(dsPtr); } - - /* - * It is possible that more than one FD_ACCEPT has been sent, so an extra - * count must be kept. Decrement the count, and reset the readyEvent bit - * if the count is no longer > 0. - */ - statePtr->acceptEventCount--; - - if (statePtr->acceptEventCount <= 0) { - statePtr->readyEvents &= ~(FD_ACCEPT); + 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); } - - 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 statePtr and fds. - * If TcpAccept() accepts a socket we must return immediately and let - * SocketCheckProc queue additional FD_ACCEPT events. - */ - TcpAccept(fds, newSocket, addr); - return 1; + if (hostEntPtr != NULL) { + Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name); + } else { + Tcl_DStringAppendElement(dsPtr, inet_ntoa(sockname.sin_addr)); + } + TclFormatInt(buf, ntohs(sockname.sin_port)); + Tcl_DStringAppendElement(dsPtr, buf); + if (len == 0) { + Tcl_DStringEndSublist(dsPtr); + } else { + return TCL_OK; + } + } else { + if (interp) { + TclWinConvertWSAError((DWORD) WSAGetLastError()); + Tcl_AppendResult(interp, "can't get sockname: ", + Tcl_PosixError(interp), NULL); + } + return TCL_ERROR; } - - /* Loop terminated with no sockets accepted; clear the ready mask so - * we can detect the next connection request. Note that connection - * requests are level triggered, so if there is a request already - * pending, a new event will be generated. - */ - statePtr->acceptEventCount = 0; - statePtr->readyEvents &= ~(FD_ACCEPT); - - SetEvent(tsdPtr->socketListLock); - return 1; } - SetEvent(tsdPtr->socketListLock); - - /* - * Mask off unwanted events and compute the read/write mask so we can - * notify the channel. - */ - - events = statePtr->readyEvents & statePtr->watchEvents; - - if (events & FD_CLOSE) { - /* - * If the socket was closed and the channel is still interested in - * read events, then we need to ensure that we keep polling for this - * event until someone does something with the channel. Note that we - * do this before calling Tcl_NotifyChannel so we don't have to watch - * out for the channel being deleted out from under us. This may cause - * a redundant trip through the event loop, but it's simpler than - * trying to do unwind protection. - */ - - Tcl_Time blockTime = { 0, 0 }; - - Tcl_SetMaxBlockTime(&blockTime); - mask |= TCL_READABLE|TCL_WRITABLE; - } else if (events & FD_READ) { - - /* - * Throw the readable event if an async connect failed. - */ - - if ( statePtr->flags & TCP_ASYNC_FAILED ) { - - mask |= TCL_READABLE; +#ifdef TCL_FEATURE_KEEPALIVE_NAGLE + if (len == 0 || !strncmp(optionName, "-keepalive", len)) { + int optlen; + BOOL opt = FALSE; + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-keepalive"); + } + optlen = sizeof(BOOL); + getsockopt(sock, SOL_SOCKET, SO_KEEPALIVE, (char *)&opt, &optlen); + if (opt) { + Tcl_DStringAppendElement(dsPtr, "1"); } else { - fd_set readFds; - struct timeval timeout; - - /* - * We must check to see if data is really available, since someone - * could have consumed the data in the meantime. Turn off async - * notification so select will work correctly. If the socket is - * still readable, notify the channel driver, otherwise reset the - * async select handler and keep waiting. - */ - - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) UNSELECT, (LPARAM) statePtr); - - FD_ZERO(&readFds); - FD_SET(statePtr->sockets->fd, &readFds); - timeout.tv_usec = 0; - timeout.tv_sec = 0; - - if (select(0, &readFds, NULL, NULL, &timeout) != 0) { - mask |= TCL_READABLE; - } else { - statePtr->readyEvents &= ~(FD_READ); - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) SELECT, (LPARAM) statePtr); - } + Tcl_DStringAppendElement(dsPtr, "0"); + } + if (len > 0) { + return TCL_OK; } } - /* - * writable event - */ + if (len == 0 || !strncmp(optionName, "-nagle", len)) { + int optlen; + BOOL opt = FALSE; - if (events & FD_WRITE) { - mask |= TCL_WRITABLE; + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-nagle"); + } + optlen = sizeof(BOOL); + getsockopt(sock, IPPROTO_TCP, TCP_NODELAY, (char *)&opt, + &optlen); + if (opt) { + Tcl_DStringAppendElement(dsPtr, "0"); + } else { + Tcl_DStringAppendElement(dsPtr, "1"); + } + if (len > 0) { + return TCL_OK; + } } +#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/ - /* - * Call registered event procedures - */ - - if (mask) { - Tcl_NotifyChannel(statePtr->channel, mask); + if (len > 0) { +#ifdef TCL_FEATURE_KEEPALIVE_NAGLE + return Tcl_BadChannelOption(interp, optionName, + "peername sockname keepalive nagle"); +#else + return Tcl_BadChannelOption(interp, optionName, "peername sockname"); +#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/ } - return 1; + + return TCL_OK; } /* *---------------------------------------------------------------------- * - * AddSocketInfoFd -- + * TcpWatchProc -- * - * This function adds a SOCKET file descriptor to the 'sockets' linked - * list of a TcpState structure. + * Informs the channel driver of the events that the generic channel code + * wishes to receive on this socket. * * Results: * None. * * Side effects: - * None, except for allocation of memory. + * May cause the notifier to poll if any of the specified conditions are + * already true. * *---------------------------------------------------------------------- */ static void -AddSocketInfoFd( - TcpState *statePtr, - SOCKET socket) -{ - TcpFdList *fds = statePtr->sockets; - - if ( fds == NULL ) { - /* Add the first FD */ - statePtr->sockets = ckalloc(sizeof(TcpFdList)); - fds = statePtr->sockets; - } else { - /* Find end of list and append FD */ - while ( fds->next != NULL ) { - fds = fds->next; - } - - fds->next = ckalloc(sizeof(TcpFdList)); - fds = fds->next; - } - - /* Populate new FD */ - fds->fd = socket; - fds->statePtr = statePtr; - fds->next = NULL; -} - - -/* - *---------------------------------------------------------------------- - * - * NewSocketInfo -- - * - * This function allocates and initializes a new TcpState structure. - * - * Results: - * Returns a newly allocated TcpState. - * - * Side effects: - * None, except for allocation of memory. - * - *---------------------------------------------------------------------- - */ - -static TcpState * -NewSocketInfo(SOCKET socket) +TcpWatchProc( + ClientData instanceData, /* The socket state. */ + int mask) /* Events of interest; an OR-ed combination of + * TCL_READABLE, TCL_WRITABLE and + * TCL_EXCEPTION. */ { - TcpState *statePtr = ckalloc(sizeof(TcpState)); - - memset(statePtr, 0, sizeof(TcpState)); + SocketInfo *infoPtr = (SocketInfo *) instanceData; /* - * TIP #218. Removed the code inserting the new structure into the global - * list. This is now handled in the thread action callbacks, and only - * there. + * Update the watch events mask. Only if the socket is not a server + * socket. Fix for SF Tcl Bug #557878. */ - AddSocketInfoFd(statePtr, socket); + if (!infoPtr->acceptProc) { + infoPtr->watchEvents = 0; + if (mask & TCL_READABLE) { + infoPtr->watchEvents |= (FD_READ|FD_CLOSE|FD_ACCEPT); + } + if (mask & TCL_WRITABLE) { + infoPtr->watchEvents |= (FD_WRITE|FD_CLOSE|FD_CONNECT); + } + + /* + * If there are any conditions already set, then tell the notifier to + * poll rather than block. + */ - return statePtr; + if (infoPtr->readyEvents & infoPtr->watchEvents) { + Tcl_Time blockTime = { 0, 0 }; + Tcl_SetMaxBlockTime(&blockTime); + } + } } /* *---------------------------------------------------------------------- * - * WaitForSocketEvent -- + * TcpGetProc -- * - * Waits until one of the specified events occurs on a socket. - * For event FD_CONNECT use WaitForConnect. + * Called from Tcl_GetChannelHandle to retrieve an OS handle from inside + * a TCP socket based channel. * * Results: - * Returns 1 on success or 0 on failure, with an error code in - * errorCodePtr. + * Returns TCL_OK with the socket in handlePtr. * * Side effects: - * Processes socket events off the system queue. + * None. * *---------------------------------------------------------------------- */ static int -WaitForSocketEvent( - TcpState *statePtr, /* Information about this socket. */ - int events, /* Events to look for. May be one of - * FD_READ or FD_WRITE. - */ - int *errorCodePtr) /* Where to store errors? */ +TcpGetHandleProc( + ClientData instanceData, /* The socket state. */ + int direction, /* Not used. */ + ClientData *handlePtr) /* Where to store the handle. */ { - int result = 1; - int oldMode; - ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); - /* - * Be sure to disable event servicing so we are truly modal. - */ - - oldMode = Tcl_SetServiceMode(TCL_SERVICE_NONE); - - /* - * Reset WSAAsyncSelect so we have a fresh set of events pending. - */ - - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT, - (LPARAM) statePtr); - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, - (LPARAM) statePtr); - - while (1) { - int event_found; - - /* get statePtr lock */ - WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + SocketInfo *statePtr = (SocketInfo *) instanceData; - /* Check if event occured */ - event_found = (statePtr->readyEvents & events); - - /* Free list lock */ - SetEvent(tsdPtr->socketListLock); - - /* exit loop if event occured */ - if (event_found) { - break; - } - - /* Exit loop if event did not occur but this is a non-blocking channel */ - if (statePtr->flags & TCP_NONBLOCKING) { - *errorCodePtr = EWOULDBLOCK; - result = 0; - break; - } - - /* - * Wait until something happens. - */ - - WaitForSingleObject(tsdPtr->readyEvent, INFINITE); - } - - (void) Tcl_SetServiceMode(oldMode); - return result; + *handlePtr = (ClientData) statePtr->socket; + return TCL_OK; } /* @@ -2986,14 +2224,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. @@ -3056,9 +2294,8 @@ SocketProc( { int event, error; SOCKET socket; - TcpState *statePtr; + SocketInfo *infoPtr; int info_found = 0; - TcpFdList *fds = NULL; ThreadSpecificData *tsdPtr = (ThreadSpecificData *) #ifdef _WIN64 GetWindowLongPtr(hwnd, GWLP_USERDATA); @@ -3095,16 +2332,15 @@ SocketProc( error = WSAGETSELECTERROR(lParam); socket = (SOCKET) wParam; - WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - /* * Find the specified socket on the socket list and update its * eventState flag. */ - for (statePtr = tsdPtr->socketList; statePtr != NULL; - statePtr = statePtr->nextPtr) { - if ( FindFDInList(statePtr,socket) ) { + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + for (infoPtr = tsdPtr->socketList; infoPtr != NULL; + infoPtr = infoPtr->nextPtr) { + if (infoPtr->socket == socket) { info_found = 1; break; } @@ -3114,9 +2350,9 @@ SocketProc( * list */ if ( !info_found - && tsdPtr->pendingTcpState != NULL - && FindFDInList(tsdPtr->pendingTcpState,socket) ) { - statePtr = tsdPtr->pendingTcpState; + && tsdPtr->pendingSocketInfo != NULL + && tsdPtr->pendingSocketInfo->socket ==socket ) { + infoPtr = tsdPtr->pendingSocketInfo; info_found = 1; } if (info_found) { @@ -3130,29 +2366,44 @@ SocketProc( */ if (event & FD_CLOSE) { - statePtr->acceptEventCount = 0; - statePtr->readyEvents &= ~(FD_WRITE|FD_ACCEPT); + infoPtr->acceptEventCount = 0; + infoPtr->readyEvents &= ~(FD_WRITE|FD_ACCEPT); } else if (event & FD_ACCEPT) { - statePtr->acceptEventCount++; + infoPtr->acceptEventCount++; } if (event & FD_CONNECT) { /* + * The socket is now connected, clear the async connect + * flag. + */ + + infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); + + /* * Remember any error that occurred so we can report * connection failures. */ + if (error != ERROR_SUCCESS) { - statePtr->notifierConnectError = error; + /* Async Connect error */ + TclWinConvertWSAError((DWORD) error); + infoPtr->lastError = Tcl_GetErrno(); + /* Fire also readable event on connect failure */ + infoPtr->readyEvents |= FD_READ; } + + /* fire writable event on connect */ + infoPtr->readyEvents |= FD_WRITE; + } - /* - * Inform main thread about signaled events - */ - statePtr->readyEvents |= event; + + infoPtr->readyEvents |= event; /* * Wake up the Main Thread. */ + SetEvent(tsdPtr->readyEvent); Tcl_ThreadAlert(tsdPtr->threadId); } @@ -3160,18 +2411,20 @@ SocketProc( break; case SOCKET_SELECT: - statePtr = (TcpState *) lParam; - for (fds = statePtr->sockets; fds != NULL; fds = fds->next) { - if (wParam == SELECT) { - WSAAsyncSelect(fds->fd, hwnd, - SOCKET_MESSAGE, statePtr->selectEvents); - } else { - /* - * Clear the selection mask - */ + infoPtr = (SocketInfo *) lParam; + if (wParam == SELECT) { + /* + * Start notification by windows messages on socket events + */ - WSAAsyncSelect(fds->fd, hwnd, 0, 0); - } + WSAAsyncSelect(infoPtr->socket, hwnd, + SOCKET_MESSAGE, infoPtr->selectEvents); + } else { + /* + * UNSELECT: Clear the selection mask + */ + + WSAAsyncSelect(infoPtr->socket, hwnd, 0, 0); } break; @@ -3186,31 +2439,83 @@ SocketProc( /* *---------------------------------------------------------------------- * - * FindFDInList -- + * Tcl_GetHostName -- * - * Return true, if the given file descriptior is contained in the - * file descriptor list. + * Returns the name of the local host. * * Results: - * true if found. + * A string containing the network name for this machine. The caller must + * not modify or free this string. * * Side effects: + * Caches the name to return for future calls. * *---------------------------------------------------------------------- */ -static int -FindFDInList( - TcpState *statePtr, - SOCKET socket) +const char * +Tcl_GetHostName(void) { - TcpFdList *fds; - for (fds = statePtr->sockets; fds != NULL; fds = fds->next) { - if (fds->fd == socket) { - return 1; + return Tcl_GetString(TclGetProcessGlobalValue(&hostName)); +} + +/* + *---------------------------------------------------------------------- + * + * InitializeHostName -- + * + * This routine sets the process global value of the name of the local + * host on which the process is running. + * + * Results: + * None. + * + *---------------------------------------------------------------------- + */ + +void +InitializeHostName( + char **valuePtr, + int *lengthPtr, + Tcl_Encoding *encodingPtr) +{ + WCHAR wbuf[MAX_COMPUTERNAME_LENGTH + 1]; + DWORD length = sizeof(wbuf) / sizeof(WCHAR); + Tcl_DString ds; + + if ((*tclWinProcs->getComputerNameProc)(wbuf, &length) != 0) { + /* + * Convert string from native to UTF then change to lowercase. + */ + + Tcl_UtfToLower(Tcl_WinTCharToUtf((TCHAR *) wbuf, -1, &ds)); + + } else { + Tcl_DStringInit(&ds); + if (TclpHasSockets(NULL) == TCL_OK) { + /* + * The buffer size of 256 is recommended by the MSDN page that + * documents gethostname() as being always adequate. + */ + + Tcl_DString inDs; + + Tcl_DStringInit(&inDs); + Tcl_DStringSetLength(&inDs, 256); + if (gethostname(Tcl_DStringValue(&inDs), + Tcl_DStringLength(&inDs)) == 0) { + Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&inDs), -1, + &ds); + } + Tcl_DStringFree(&inDs); } } - return 0; + + *encodingPtr = Tcl_GetEncoding(NULL, "utf-8"); + *lengthPtr = Tcl_DStringLength(&ds); + *valuePtr = ckalloc((unsigned int) (*lengthPtr)+1); + memcpy(*valuePtr, Tcl_DStringValue(&ds), (size_t)(*lengthPtr)+1); + Tcl_DStringFree(&ds); } /* @@ -3218,11 +2523,10 @@ FindFDInList( * * TclWinGetSockOpt, et al. -- * - * Those functions are historically exported by the stubs table and - * just use the original system calls now. - * - * Warning: - * Those functions are depreciated and will be removed with TCL 9.0. + * These functions are wrappers that let us bind the WinSock API + * dynamically so we can run on systems that don't have the wsock32.dll. + * We need wrappers for these interfaces because they are called from the + * generic Tcl code. * * Results: * As defined for each function. @@ -3235,35 +2539,26 @@ FindFDInList( #undef TclWinGetSockOpt int -TclWinGetSockOpt( - SOCKET s, - int level, - int optname, - char *optval, - int *optlen) +TclWinGetSockOpt(SOCKET s, int level, int optname, char *optval, + int *optlen) { - return getsockopt(s, level, optname, optval, optlen); } + #undef TclWinSetSockOpt int -TclWinSetSockOpt( - SOCKET s, - int level, - int optname, - const char *optval, +TclWinSetSockOpt(SOCKET s, int level, int optname, const char *optval, int optlen) { return setsockopt(s, level, optname, optval, optlen); } -#undef TclpInetNtoa char * -TclpInetNtoa( - struct in_addr addr) +TclpInetNtoa(struct in_addr addr) { return inet_ntoa(addr); } + #undef TclWinGetServByName struct servent * TclWinGetServByName( @@ -3295,7 +2590,7 @@ TcpThreadActionProc( int action) { ThreadSpecificData *tsdPtr; - TcpState *statePtr = instanceData; + SocketInfo *infoPtr = (SocketInfo *) instanceData; int notifyCmd; if (action == TCL_CHANNEL_THREAD_INSERT) { @@ -3311,18 +2606,18 @@ TcpThreadActionProc( tsdPtr = TCL_TSD_INIT(&dataKey); WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - statePtr->nextPtr = tsdPtr->socketList; - tsdPtr->socketList = statePtr; - - if (statePtr == tsdPtr->pendingTcpState) { - tsdPtr->pendingTcpState = NULL; + infoPtr->nextPtr = tsdPtr->socketList; + tsdPtr->socketList = infoPtr; + + if (infoPtr == tsdPtr->pendingSocketInfo) { + tsdPtr->pendingSocketInfo = NULL; } - + SetEvent(tsdPtr->socketListLock); notifyCmd = SELECT; } else { - TcpState **nextPtrPtr; + SocketInfo **nextPtrPtr; int removed = 0; tsdPtr = TCL_TSD_INIT(&dataKey); @@ -3335,8 +2630,8 @@ TcpThreadActionProc( WaitForSingleObject(tsdPtr->socketListLock, INFINITE); for (nextPtrPtr = &(tsdPtr->socketList); (*nextPtrPtr) != NULL; nextPtrPtr = &((*nextPtrPtr)->nextPtr)) { - if ((*nextPtrPtr) == statePtr) { - (*nextPtrPtr) = statePtr->nextPtr; + if ((*nextPtrPtr) == infoPtr) { + (*nextPtrPtr) = infoPtr->nextPtr; removed = 1; break; } @@ -3362,7 +2657,7 @@ TcpThreadActionProc( */ SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) notifyCmd, (LPARAM) statePtr); + (WPARAM) notifyCmd, (LPARAM) infoPtr); } /* @@ -3370,7 +2665,5 @@ TcpThreadActionProc( * mode: c * c-basic-offset: 4 * fill-column: 78 - * tab-width: 8 - * indent-tabs-mode: nil * End: */ diff --git a/win/tclWinTest.c b/win/tclWinTest.c index b3ad626..e493fbf 100644 --- a/win/tclWinTest.c +++ b/win/tclWinTest.c @@ -9,15 +9,12 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#ifndef USE_TCL_STUBS -# define USE_TCL_STUBS -#endif #include "tclInt.h" /* * For TestplatformChmod on Windows */ -#ifdef _WIN32 +#ifdef __WIN32__ #include <aclapi.h> #endif @@ -32,8 +29,9 @@ * Forward declarations of functions defined later in this file: */ -static int TesteventloopCmd(ClientData dummy, Tcl_Interp* interp, - int objc, Tcl_Obj *const objv[]); +int TclplatformtestInit(Tcl_Interp *interp); +static int TesteventloopCmd(ClientData dummy, Tcl_Interp *interp, + int argc, const char **argv); static int TestvolumetypeCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -43,8 +41,8 @@ static int TestwinsleepCmd(ClientData dummy, Tcl_Interp* interp, int objc, Tcl_Obj *const objv[]); static Tcl_ObjCmdProc TestExceptionCmd; static int TestplatformChmod(const char *nativePath, int pmode); -static int TestchmodCmd(ClientData dummy, Tcl_Interp* interp, - int objc, Tcl_Obj *const objv[]); +static int TestchmodCmd(ClientData dummy, + Tcl_Interp *interp, int argc, const char **argv); /* *---------------------------------------------------------------------- @@ -71,8 +69,8 @@ TclplatformtestInit( * Add commands for platform specific tests for Windows here. */ - Tcl_CreateObjCommand(interp, "testchmod", TestchmodCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testeventloop", TesteventloopCmd, NULL, NULL); + Tcl_CreateCommand(interp, "testchmod", TestchmodCmd, NULL, NULL); + Tcl_CreateCommand(interp, "testeventloop", TesteventloopCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testvolumetype", TestvolumetypeCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testwinclock", TestwinclockCmd, NULL, NULL); @@ -103,20 +101,21 @@ static int TesteventloopCmd( ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { static int *framePtr = NULL;/* Pointer to integer on stack frame of * innermost invocation of the "wait" * subcommand. */ - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ..."); + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], + " option ... \"", NULL); return TCL_ERROR; } - if (strcmp(Tcl_GetString(objv[1]), "done") == 0) { + if (strcmp(argv[1], "done") == 0) { *framePtr = 1; - } else if (strcmp(Tcl_GetString(objv[1]), "wait") == 0) { + } else if (strcmp(argv[1], "wait") == 0) { int *oldFramePtr, done; int oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL); @@ -151,7 +150,7 @@ TesteventloopCmd( (void) Tcl_SetServiceMode(oldMode); framePtr = oldFramePtr; } else { - Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]), + Tcl_AppendResult(interp, "bad option \"", argv[1], "\": must be done or wait", NULL); return TCL_ERROR; } @@ -185,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?"); @@ -210,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 } @@ -340,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", @@ -397,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 @@ -407,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 = { @@ -418,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 @@ -437,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; } @@ -456,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; @@ -475,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; } @@ -500,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; } @@ -515,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; } @@ -525,7 +621,7 @@ TestplatformChmod( LPVOID pACE2; ACE_HEADER *phACE2; - if (!GetAce(curAcl, j, &pACE2)) { + if (!getAceProc(curAcl, j, &pACE2)) { goto done; } @@ -548,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; } @@ -558,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; } @@ -568,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; @@ -576,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); @@ -622,25 +718,29 @@ static int TestchmodCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Parameter count */ - Tcl_Obj *const * objv) /* Parameter vector */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ { int i, mode; + char *rest; - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "mode file ?file ...?"); + if (argc < 2) { + usage: + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " mode file ?file ...?", NULL); return TCL_ERROR; } - if (Tcl_GetIntFromObj(interp, objv[1], &mode) != TCL_OK) { - return TCL_ERROR; + mode = (int) strtol(argv[1], &rest, 8); + if ((rest == argv[1]) || (*rest != '\0')) { + goto usage; } - for (i = 2; i < objc; i++) { + for (i = 2; i < argc; i++) { Tcl_DString buffer; const char *translated; - translated = Tcl_TranslateFileName(interp, Tcl_GetString(objv[i]), &buffer); + translated = Tcl_TranslateFileName(interp, argv[i], &buffer); if (translated == NULL) { return TCL_ERROR; } diff --git a/win/tclWinThrd.c b/win/tclWinThrd.c index 927e115..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()); } /* @@ -569,8 +568,6 @@ Tcl_MutexLock( { CRITICAL_SECTION *csPtr; -retry: - if (*mutexPtr == NULL) { MASTER_LOCK; @@ -579,18 +576,14 @@ retry: */ if (*mutexPtr == NULL) { - csPtr = ckalloc(sizeof(CRITICAL_SECTION)); + csPtr = (CRITICAL_SECTION *) ckalloc(sizeof(CRITICAL_SECTION)); InitializeCriticalSection(csPtr); *mutexPtr = (Tcl_Mutex)csPtr; TclRememberMutex(mutexPtr); } MASTER_UNLOCK; } - csPtr = *((CRITICAL_SECTION **)mutexPtr); - if (csPtr == NULL) { - goto retry; - } EnterCriticalSection(csPtr); } @@ -644,7 +637,7 @@ TclpFinalizeMutex( if (csPtr != NULL) { DeleteCriticalSection(csPtr); - ckfree(csPtr); + ckfree((char *) csPtr); *mutexPtr = NULL; } } @@ -675,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 */ @@ -714,7 +707,8 @@ Tcl_ConditionWait( * and initializing that may drop back into the Master Lock. */ - Tcl_CreateThreadExitHandler(FinalizeConditionEvent, tsdPtr); + Tcl_CreateThreadExitHandler(FinalizeConditionEvent, + (ClientData) tsdPtr); } } @@ -726,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; @@ -775,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); @@ -937,7 +930,7 @@ TclpFinalizeCondition( if (winCondPtr != NULL) { DeleteCriticalSection(&winCondPtr->condLock); - ckfree(winCondPtr); + ckfree((char *) winCondPtr); *condPtr = NULL; } } @@ -980,7 +973,7 @@ TclpFreeAllocMutex( void * TclpGetAllocCache(void) { - void *result; + VOID *result; if (!once) { /* @@ -1045,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 7045c72..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); } /* @@ -385,7 +414,7 @@ NativeGetTime( WaitForSingleObject(timeInfo.readyEvent, INFINITE); CloseHandle(timeInfo.readyEvent); - Tcl_CreateExitHandler(StopCalibration, NULL); + Tcl_CreateExitHandler(StopCalibration, (ClientData) NULL); } timeInfo.initialized = TRUE; } @@ -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 55fe75f..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.3 diff --git a/win/tclsh.ico b/win/tclsh.ico Binary files differindex e254318..8bcaf48 100644 --- a/win/tclsh.ico +++ b/win/tclsh.ico |