diff options
Diffstat (limited to 'win')
37 files changed, 8239 insertions, 6844 deletions
diff --git a/win/Makefile.in b/win/Makefile.in index b3be22d..9d955cd 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -81,7 +81,12 @@ CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@ #CFLAGS = $(CFLAGS_DEBUG) #CFLAGS = $(CFLAGS_OPTIMIZE) #CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE) -CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@ -D_ATL_XP_TARGETING +CFLAGS = @CFLAGS@ @CFLAGS_DEFAULT@ -DUNICODE -D_UNICODE -D_ATL_XP_TARGETING + +# To compile without backward compatibility and deprecated code uncomment the +# following +NO_DEPRECATED_FLAGS = +#NO_DEPRECATED_FLAGS = -DTCL_NO_DEPRECATED # To enable compilation debugging reverse the comment characters on one of the # following lines. @@ -89,15 +94,15 @@ COMPILE_DEBUG_FLAGS = #COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG #COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS -# Special compiler flags to use when building man2tcl on Windows. -MAN2TCLFLAGS = @MAN2TCLFLAGS@ - SRC_DIR = @srcdir@ ROOT_DIR = @srcdir@/.. -GENERIC_DIR = @srcdir@/../generic -TOMMATH_DIR = @srcdir@/../libtommath -WIN_DIR = @srcdir@ -COMPAT_DIR = @srcdir@/../compat +TOP_DIR = $(shell cd @srcdir@/..; pwd -P) +GENERIC_DIR = $(TOP_DIR)/generic +TOMMATH_DIR = $(TOP_DIR)/libtommath +WIN_DIR = $(TOP_DIR)/win +COMPAT_DIR = $(TOP_DIR)/compat +PKGS_DIR = $(TOP_DIR)/pkgs +ZLIB_DIR = $(COMPAT_DIR)/zlib # Converts a POSIX path to a Windows native path. CYGPATH = @CYGPATH@ @@ -111,6 +116,7 @@ GENERIC_DIR_NATIVE = $(shell $(CYGPATH) '$(GENERIC_DIR)') TOMMATH_DIR_NATIVE = $(shell $(CYGPATH) '$(TOMMATH_DIR)') WIN_DIR_NATIVE = $(shell $(CYGPATH) '$(WIN_DIR)') ROOT_DIR_NATIVE = $(shell $(CYGPATH) '$(ROOT_DIR)') +ZLIB_DIR_NATIVE = $(shell $(CYGPATH) '$(ZLIB_DIR)') #GENERIC_DIR_NATIVE = $(GENERIC_DIR) #TOMMATH_DIR_NATIVE = $(TOMMATH_DIR) #WIN_DIR_NATIVE = $(WIN_DIR) @@ -118,7 +124,7 @@ ROOT_DIR_NATIVE = $(shell $(CYGPATH) '$(ROOT_DIR)') # Fully qualify library path so that `make test` # does not depend on the current directory. -LIBRARY_DIR1 = $(shell cd '$(ROOT_DIR_NATIVE)/library' ; pwd) +LIBRARY_DIR1 = $(shell cd '$(ROOT_DIR_NATIVE)/library' ; pwd -P) LIBRARY_DIR = $(shell $(CYGPATH) '$(LIBRARY_DIR1)') DLLSUFFIX = @DLLSUFFIX@ LIBSUFFIX = @LIBSUFFIX@ @@ -135,37 +141,33 @@ TCL_STUB_LIB_FILE = @TCL_STUB_LIB_FILE@ TCL_DLL_FILE = @TCL_DLL_FILE@ TCL_LIB_FILE = @TCL_LIB_FILE@ DDE_DLL_FILE = tcldde$(DDEVER)${DLLSUFFIX} -DDE_LIB_FILE = tcldde$(DDEVER)${LIBSUFFIX} +DDE_LIB_FILE = @LIBPREFIX@tcldde$(DDEVER)${LIBSUFFIX} REG_DLL_FILE = tclreg$(REGVER)${DLLSUFFIX} -REG_LIB_FILE = tclreg$(REGVER)${LIBSUFFIX} -PIPE_DLL_FILE = tclpip$(VER)${DLLSUFFIX} - -SHARED_LIBRARIES = $(TCL_DLL_FILE) $(TCL_STUB_LIB_FILE) \ - $(DDE_DLL_FILE) $(REG_DLL_FILE) $(PIPE_DLL_FILE) -STATIC_LIBRARIES = $(TCL_LIB_FILE) $(REG_LIB_FILE) $(DDE_LIB_FILE) - -# To compile without backward compatibility and deprecated code -# uncomment the following -NO_DEPRECATED_FLAGS = -#NO_DEPRECATED_FLAGS = -DTCL_NO_DEPRECATED +REG_LIB_FILE = @LIBPREFIX@tclreg$(REGVER)${LIBSUFFIX} +TEST_DLL_FILE = tcltest$(VER)${DLLSUFFIX} +TEST_LIB_FILE = @LIBPREFIX@tcltest$(VER)${LIBSUFFIX} +ZLIB_DLL_FILE = zlib1.dll -# TCL_EXE is the name of a tclsh executable that is available *BEFORE* running -# make for the first time. Certain build targets (make genstubs) need it to be -# available on the PATH. This executable should *NOT* be required just to do a -# normal build although it can be required to run make dist. -TCL_EXE = tclsh +SHARED_LIBRARIES = $(TCL_DLL_FILE) @ZLIB_DLL_FILE@ +STATIC_LIBRARIES = $(TCL_LIB_FILE) TCLSH = tclsh$(VER)${EXESUFFIX} -TCLTEST = tcltest${EXEEXT} CAT32 = cat32$(EXEEXT) MAN2TCL = man2tcl$(EXEEXT) +# For cross-compiled builds, TCL_EXE is the name of a tclsh executable that is +# available *BEFORE* running make for the first time. Certain build targets +# (make genstubs, make install) need it to be available on the PATH. This +# executable should *NOT* be required just to do a normal build although +# it can be required to run make dist. +TCL_EXE = @TCL_EXE@ + @SET_MAKE@ # Setting the VPATH variable to a list of paths will cause the Makefile to # look into these paths when resolving .c to .obj dependencies. -VPATH = $(GENERIC_DIR):$(TOMMATH_DIR):$(WIN_DIR):$(COMPAT_DIR) +VPATH = $(GENERIC_DIR):$(TOMMATH_DIR):$(WIN_DIR):$(COMPAT_DIR):$(ZLIB_DIR) AR = @AR@ RANLIB = @RANLIB@ @@ -183,10 +185,10 @@ EXEEXT = @EXEEXT@ OBJEXT = @OBJEXT@ STLIB_LD = @STLIB_LD@ SHLIB_LD = @SHLIB_LD@ -SHLIB_LD_LIBS = @SHLIB_LD_LIBS@ $(LIBS) +SHLIB_LD_LIBS = @SHLIB_LD_LIBS@ SHLIB_CFLAGS = @SHLIB_CFLAGS@ SHLIB_SUFFIX = @SHLIB_SUFFIX@ -LIBS = @LIBS@ +LIBS = @LIBS@ $(shell $(CYGPATH) '@ZLIB_LIBS@') RMDIR = rm -rf MKDIR = mkdir -p @@ -195,9 +197,9 @@ RM = rm -f COPY = cp CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${TCL_SHLIB_CFLAGS} \ --I"${GENERIC_DIR_NATIVE}" -DTCL_TOMMATH -DMP_PREC=4 -I"${TOMMATH_DIR_NATIVE}" \ --I"${WIN_DIR_NATIVE}" ${AC_FLAGS} \ -${COMPILE_DEBUG_FLAGS} ${NO_DEPRECATED_FLAGS} +-I"${ZLIB_DIR_NATIVE}" -I"${GENERIC_DIR_NATIVE}" -DTCL_TOMMATH \ +-DMP_PREC=4 -I"${TOMMATH_DIR_NATIVE}" -I"${WIN_DIR_NATIVE}" \ +${AC_FLAGS} ${COMPILE_DEBUG_FLAGS} ${NO_DEPRECATED_FLAGS} CC_OBJNAME = @CC_OBJNAME@ CC_EXENAME = @CC_EXENAME@ @@ -212,8 +214,7 @@ TCLTEST_OBJS = \ tclTestObj.$(OBJEXT) \ tclTestProcBodyObj.$(OBJEXT) \ tclThreadTest.$(OBJEXT) \ - tclWinTest.$(OBJEXT) \ - testMain.$(OBJEXT) + tclWinTest.$(OBJEXT) GENERIC_OBJS = \ regcomp.$(OBJEXT) \ @@ -221,6 +222,7 @@ GENERIC_OBJS = \ regfree.$(OBJEXT) \ regerror.$(OBJEXT) \ tclAlloc.$(OBJEXT) \ + tclAssembly.$(OBJEXT) \ tclAsync.$(OBJEXT) \ tclBasic.$(OBJEXT) \ tclBinary.$(OBJEXT) \ @@ -230,12 +232,16 @@ GENERIC_OBJS = \ tclCmdIL.$(OBJEXT) \ tclCmdMZ.$(OBJEXT) \ tclCompCmds.$(OBJEXT) \ + tclCompCmdsGR.$(OBJEXT) \ + tclCompCmdsSZ.$(OBJEXT) \ tclCompExpr.$(OBJEXT) \ tclCompile.$(OBJEXT) \ tclConfig.$(OBJEXT) \ tclDate.$(OBJEXT) \ tclDictObj.$(OBJEXT) \ + tclDisassemble.$(OBJEXT) \ tclEncoding.$(OBJEXT) \ + tclEnsemble.$(OBJEXT) \ tclEnv.$(OBJEXT) \ tclEvent.$(OBJEXT) \ tclExecute.$(OBJEXT) \ @@ -250,6 +256,7 @@ GENERIC_OBJS = \ tclIOCmd.$(OBJEXT) \ tclIOGT.$(OBJEXT) \ tclIORChan.$(OBJEXT) \ + tclIORTrans.$(OBJEXT) \ tclIOSock.$(OBJEXT) \ tclIOUtil.$(OBJEXT) \ tclLink.$(OBJEXT) \ @@ -257,9 +264,18 @@ GENERIC_OBJS = \ tclListObj.$(OBJEXT) \ tclLoad.$(OBJEXT) \ tclMain.$(OBJEXT) \ + tclMain2.$(OBJEXT) \ tclNamesp.$(OBJEXT) \ tclNotify.$(OBJEXT) \ + tclOO.$(OBJEXT) \ + tclOOBasic.$(OBJEXT) \ + tclOOCall.$(OBJEXT) \ + tclOODefineCmds.$(OBJEXT) \ + tclOOInfo.$(OBJEXT) \ + tclOOMethod.$(OBJEXT) \ + tclOOStubInit.$(OBJEXT) \ tclObj.$(OBJEXT) \ + tclOptimize.$(OBJEXT) \ tclPanic.$(OBJEXT) \ tclParse.$(OBJEXT) \ tclPathObj.$(OBJEXT) \ @@ -276,7 +292,6 @@ GENERIC_OBJS = \ tclStringObj.$(OBJEXT) \ tclStrToD.$(OBJEXT) \ tclStubInit.$(OBJEXT) \ - tclStubLib.$(OBJEXT) \ tclThread.$(OBJEXT) \ tclThreadAlloc.$(OBJEXT) \ tclThreadJoin.$(OBJEXT) \ @@ -286,7 +301,8 @@ GENERIC_OBJS = \ tclTrace.$(OBJEXT) \ tclUtf.$(OBJEXT) \ tclUtil.$(OBJEXT) \ - tclVar.$(OBJEXT) + tclVar.$(OBJEXT) \ + tclZlib.$(OBJEXT) TOMMATH_OBJS = \ bncore.${OBJEXT} \ @@ -371,47 +387,48 @@ WIN_OBJS = \ tclWinThrd.$(OBJEXT) \ tclWinTime.$(OBJEXT) -PIPE_OBJS = stub16.$(OBJEXT) - DDE_OBJS = tclWinDde.$(OBJEXT) REG_OBJS = tclWinReg.$(OBJEXT) -STUB_OBJS = tclStubLib.$(OBJEXT) +STUB_OBJS = \ + tclStubLib.$(OBJEXT) \ + tclTomMathStubLib.$(OBJEXT) \ + tclOOStubLib.$(OBJEXT) TCLSH_OBJS = tclAppInit.$(OBJEXT) -TCL_OBJS = ${GENERIC_OBJS} $(TOMMATH_OBJS) ${WIN_OBJS} +ZLIB_OBJS = \ + adler32.$(OBJEXT) \ + compress.$(OBJEXT) \ + crc32.$(OBJEXT) \ + deflate.$(OBJEXT) \ + infback.$(OBJEXT) \ + inffast.$(OBJEXT) \ + inflate.$(OBJEXT) \ + inftrees.$(OBJEXT) \ + trees.$(OBJEXT) \ + uncompr.$(OBJEXT) \ + zutil.$(OBJEXT) + +TCL_OBJS = ${GENERIC_OBJS} $(TOMMATH_OBJS) ${WIN_OBJS} @ZLIB_OBJS@ TCL_DOCS = "$(ROOT_DIR_NATIVE)"/doc/*.[13n] -all: binaries libraries doc +all: binaries libraries doc packages -tcltest: binaries $(TCLTEST) +tcltest: $(TCLSH) $(TEST_DLL_FILE) -binaries: @LIBRARIES@ $(TCLSH) - -libraries: - -doc: - -winhelp: $(ROOT_DIR)/tools/man2help.tcl $(MAN2TCL) - TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ - ./$(TCLSH) "$(ROOT_DIR_NATIVE)"/tools/man2help.tcl tcl "$(VER)" $(TCL_DOCS) - hcw /c /e tcl.hpj +binaries: $(TCL_STUB_LIB_FILE) @LIBRARIES@ winextensions $(TCLSH) winextensions: ${DDE_DLL_FILE} ${REG_DLL_FILE} -$(MAN2TCL): $(ROOT_DIR)/tools/man2tcl.c - $(CC) $(CFLAGS_OPTIMIZE) $(MAN2TCLFLAGS) -o $(MAN2TCL) "$(ROOT_DIR_NATIVE)"/tools/man2tcl.c +libraries: -$(TCLSH): $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(TCLSH_OBJS) tclsh.$(RES) - $(CC) $(CFLAGS) $(TCLSH_OBJS) $(TCL_LIB_FILE) $(LIBS) \ - tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE) - @VC_MANIFEST_EMBED_EXE@ +doc: -$(TCLTEST): $(TCL_LIB_FILE) $(TCLTEST_OBJS) $(CAT32) tclsh.$(RES) - $(CC) $(CFLAGS) $(TCLTEST_OBJS) $(TCL_LIB_FILE) $(LIBS) \ +$(TCLSH): $(TCLSH_OBJS) @LIBRARIES@ $(TCL_STUB_LIB_FILE) tclsh.$(RES) + $(CC) $(CFLAGS) $(TCLSH_OBJS) $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \ tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE) @VC_MANIFEST_EMBED_EXE@ @@ -429,37 +446,33 @@ ${TCL_STUB_LIB_FILE}: ${STUB_OBJS} @MAKE_STUB_LIB@ ${STUB_OBJS} @POST_MAKE_LIB@ -${TCL_DLL_FILE}: ${TCL_OBJS} tcl.$(RES) - @$(RM) ${TCL_DLL_FILE} +${TCL_DLL_FILE}: ${TCL_OBJS} tcl.$(RES) @ZLIB_DLL_FILE@ + @$(RM) ${TCL_DLL_FILE} $(TCL_LIB_FILE) @MAKE_DLL@ ${TCL_OBJS} tcl.$(RES) $(SHLIB_LD_LIBS) @VC_MANIFEST_EMBED_DLL@ -${TCL_LIB_FILE}: ${TCL_OBJS} +${TCL_LIB_FILE}: ${TCL_OBJS} ${DDE_OBJS} ${REG_OBJS} @$(RM) ${TCL_LIB_FILE} - @MAKE_LIB@ ${TCL_OBJS} + @MAKE_LIB@ ${TCL_OBJS} ${DDE_OBJS} ${REG_OBJS} @POST_MAKE_LIB@ -${DDE_DLL_FILE}: ${DDE_OBJS} ${TCL_STUB_LIB_FILE} - @$(RM) ${DDE_DLL_FILE} +${DDE_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${DDE_OBJS} @MAKE_DLL@ ${DDE_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) -${DDE_LIB_FILE}: ${DDE_OBJS} ${TCL_LIB_FILE} - @$(RM) ${DDE_LIB_FILE} - @MAKE_LIB@ ${DDE_OBJS} ${TCL_LIB_FILE} - -${REG_DLL_FILE}: ${REG_OBJS} ${TCL_STUB_LIB_FILE} - @$(RM) ${REG_DLL_FILE} +${REG_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${REG_OBJS} @MAKE_DLL@ ${REG_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) -${REG_LIB_FILE}: ${REG_OBJS} ${TCL_LIB_FILE} - @$(RM) ${REG_LIB_FILE} - @MAKE_LIB@ ${REG_OBJS} ${TCL_LIB_FILE} - -# PIPE_DLL_FILE is actually an executable, don't build it like a DLL. +${TEST_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${TCLTEST_OBJS} + @$(RM) ${TEST_DLL_FILE} ${TEST_LIB_FILE} + @MAKE_DLL@ ${TCLTEST_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) -${PIPE_DLL_FILE}: ${PIPE_OBJS} - @$(RM) ${PIPE_DLL_FILE} - @MAKE_EXE@ $(CFLAGS) ${PIPE_OBJS} $(LIBS) $(LDFLAGS_CONSOLE) +# use pre-built zlib1.dll +${ZLIB_DLL_FILE}: ${TCL_STUB_LIB_FILE} + @if test "@ZLIB_LIBS@set" != "${ZLIB_DIR_NATIVE}/win32/zdll.libset" ; then \ + $(COPY) $(ZLIB_DIR)/win64/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \ + else \ + $(COPY) $(ZLIB_DIR)/win32/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \ + fi; # Add the object extension to the implicit rules. By default .obj is not # automatically added. @@ -474,31 +487,13 @@ tclWinInit.${OBJEXT}: tclWinInit.c $(CC) -c $(CC_SWITCHES) -DBUILD_tcl $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME) tclWinPipe.${OBJEXT}: tclWinPipe.c - $(CC) -c $(CC_SWITCHES) -DBUILD_tcl -DTCL_PIPE_DLL=\"$(PIPE_DLL_FILE)\" \ - $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME) + $(CC) -c $(CC_SWITCHES) -DBUILD_tcl $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME) testMain.${OBJEXT}: tclAppInit.c $(CC) -c $(CC_SWITCHES) -DTCL_TEST @DEPARG@ $(CC_OBJNAME) -tclTest.${OBJEXT}: tclTest.c - $(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME) - -tclTestObj.${OBJEXT}: tclTestObj.c - $(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME) - -tclWinTest.${OBJEXT}: tclWinTest.c - $(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME) - -tclAppInit.${OBJEXT} : tclAppInit.c - $(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME) - -# The following objects should be built using the stub interfaces - -tclWinReg.${OBJEXT} : tclWinReg.c - $(CC) -c $(CC_SWITCHES) -DUNICODE -D_UNICODE -DUSE_TCL_STUBS @DEPARG@ $(CC_OBJNAME) - -tclWinDde.${OBJEXT} : tclWinDde.c - $(CC) -c $(CC_SWITCHES) -DUNICODE -D_UNICODE -DUSE_TCL_STUBS @DEPARG@ $(CC_OBJNAME) +tclMain2.${OBJEXT}: tclMain.c + $(CC) -c $(CC_SWITCHES) -DBUILD_tcl -DTCL_ASCII_MAIN @DEPARG@ $(CC_OBJNAME) # TIP #59, embedding of configuration information into the binary library. # @@ -530,6 +525,11 @@ tclPkgConfig.${OBJEXT}: tclPkgConfig.c tclStubLib.${OBJEXT}: tclStubLib.c $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME) +tclTomMathStubLib.${OBJEXT}: tclTomMathStubLib.c + $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME) + +tclOOStubLib.${OBJEXT}: tclOOStubLib.c + $(CC) -c $(CC_SWITCHES) -DSTATIC_BUILD @DEPARG@ $(CC_OBJNAME) # Implicit rule for all object files that will end up in the Tcl library @@ -555,11 +555,11 @@ gendate: # run (and the results checked) after updating to a new release of libtommath. gentommath_h: - $(TCL_EXE) "$(ROOT_DIR_NATIVE)\tools\fix_tommath_h.tcl" \ - "$(TOMMATH_DIR_NATIVE)\tommath.h" \ - > "$(GENERIC_DIR_NATIVE)\tclTomMath.h" + $(TCL_EXE) "$(ROOT_DIR_NATIVE)/tools/fix_tommath_h.tcl" \ + "$(TOMMATH_DIR_NATIVE)/tommath.h" \ + > "$(GENERIC_DIR_NATIVE)/tclTomMath.h" -install: all install-binaries install-libraries install-doc +install: all install-binaries install-libraries install-doc install-packages install-binaries: binaries @for i in "$(LIB_INSTALL_DIR)" "$(BIN_INSTALL_DIR)" ; \ @@ -571,7 +571,7 @@ install-binaries: binaries else true; \ fi; \ done; - @for i in dde$(DDEDOTVER) reg$(REGDOTVER); \ + @for i in dde${DDEDOTVER} reg${REGDOTVER}; \ do \ if [ ! -d $(LIB_INSTALL_DIR)/$$i ] ; then \ echo "Making directory $(LIB_INSTALL_DIR)/$$i"; \ @@ -579,14 +579,14 @@ install-binaries: binaries else true; \ fi; \ done; - @for i in $(TCL_DLL_FILE) $(TCLSH) $(PIPE_DLL_FILE); \ + @for i in $(TCL_DLL_FILE) $(ZLIB_DLL_FILE) $(TCLSH); \ do \ if [ -f $$i ]; then \ echo "Installing $$i to $(BIN_INSTALL_DIR)/"; \ $(COPY) $$i "$(BIN_INSTALL_DIR)"; \ fi; \ done - @for i in tclConfig.sh $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE); \ + @for i in tclConfig.sh tclooConfig.sh $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE); \ do \ if [ -f $$i ]; then \ echo "Installing $$i to $(LIB_INSTALL_DIR)/"; \ @@ -595,27 +595,27 @@ install-binaries: binaries done @if [ -f $(DDE_DLL_FILE) ]; then \ echo Installing $(DDE_DLL_FILE); \ - $(COPY) $(DDE_DLL_FILE) $(LIB_INSTALL_DIR)/dde$(DDEDOTVER); \ + $(COPY) $(DDE_DLL_FILE) $(LIB_INSTALL_DIR)/dde${DDEDOTVER}; \ $(COPY) $(ROOT_DIR)/library/dde/pkgIndex.tcl \ - $(LIB_INSTALL_DIR)/dde$(DDEDOTVER); \ + $(LIB_INSTALL_DIR)/dde${DDEDOTVER}; \ fi @if [ -f $(DDE_LIB_FILE) ]; then \ echo Installing $(DDE_LIB_FILE); \ - $(COPY) $(DDE_LIB_FILE) $(LIB_INSTALL_DIR)/dde$(DDEDOTVER); \ + $(COPY) $(DDE_LIB_FILE) $(LIB_INSTALL_DIR)/dde${DDEDOTVER}; \ fi @if [ -f $(REG_DLL_FILE) ]; then \ echo Installing $(REG_DLL_FILE); \ - $(COPY) $(REG_DLL_FILE) $(LIB_INSTALL_DIR)/reg$(REGDOTVER); \ + $(COPY) $(REG_DLL_FILE) $(LIB_INSTALL_DIR)/reg${REGDOTVER}; \ $(COPY) $(ROOT_DIR)/library/reg/pkgIndex.tcl \ - $(LIB_INSTALL_DIR)/reg$(REGDOTVER); \ + $(LIB_INSTALL_DIR)/reg${REGDOTVER}; \ fi @if [ -f $(REG_LIB_FILE) ]; then \ echo Installing $(REG_LIB_FILE); \ - $(COPY) $(REG_LIB_FILE) $(LIB_INSTALL_DIR)/reg$(REGDOTVER); \ + $(COPY) $(REG_LIB_FILE) $(LIB_INSTALL_DIR)/reg${REGDOTVER}; \ fi install-libraries: libraries install-tzdata install-msgs - @for i in $(prefix)/lib $(INCLUDE_INSTALL_DIR) \ + @for i in "$$($(CYGPATH) $(prefix)/lib)" "$(INCLUDE_INSTALL_DIR)" \ $(SCRIPT_INSTALL_DIR); \ do \ if [ ! -d $$i ] ; then \ @@ -624,7 +624,7 @@ install-libraries: libraries install-tzdata install-msgs else true; \ fi; \ done; - @for i in http1.0 opt0.4 encoding ../tcl8 ../tcl8/8.4 ../tcl8/8.4/platform ../tcl8/8.5; \ + @for i in http1.0 opt0.4 encoding ../tcl8 ../tcl8/8.4 ../tcl8/8.4/platform ../tcl8/8.5 ../tcl8/8.6; \ do \ if [ ! -d $(SCRIPT_INSTALL_DIR)/$$i ] ; then \ echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ @@ -634,6 +634,7 @@ install-libraries: libraries install-tzdata install-msgs done; @echo "Installing header files"; @for i in "$(GENERIC_DIR)/tcl.h" "$(GENERIC_DIR)/tclDecls.h" \ + "$(GENERIC_DIR)/tclOO.h" "$(GENERIC_DIR)/tclOODecls.h" \ "$(GENERIC_DIR)/tclPlatDecls.h" \ "$(GENERIC_DIR)/tclTomMath.h" \ "$(GENERIC_DIR)/tclTomMathDecls.h"; \ @@ -650,15 +651,15 @@ install-libraries: libraries install-tzdata install-msgs do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \ done; - @echo "Installing package http 2.7.14 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/http-2.7.14.tm; + @echo "Installing package http 2.9.0 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.9.0.tm; @echo "Installing library opt0.4 directory"; @for j in $(ROOT_DIR)/library/opt/*.tcl; \ do \ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ done; - @echo "Installing package msgcat 1.5.2 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.5.2.tm; + @echo "Installing package msgcat 1.6.1 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.6.1.tm; @echo "Installing package tcltest 2.5.0 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.5.0.tm; @echo "Installing package platform 1.0.14 as a Tcl Module"; @@ -672,14 +673,12 @@ install-libraries: libraries install-tzdata install-msgs install-tzdata: @echo "Installing time zone data" - @TCL_LIBRARY="${LIBRARY_DIR}"; export TCL_LIBRARY; \ - ./$(TCLSH) "$(ROOT_DIR)/tools/installData.tcl" \ + @$(TCL_EXE) "$(ROOT_DIR)/tools/installData.tcl" \ "$(ROOT_DIR)/library/tzdata" "$(SCRIPT_INSTALL_DIR)/tzdata" install-msgs: @echo "Installing message catalogs" - @TCL_LIBRARY="${LIBRARY_DIR}"; export TCL_LIBRARY; \ - ./$(TCLSH) "$(ROOT_DIR)/tools/installData.tcl" \ + @$(TCL_EXE) "$(ROOT_DIR)/tools/installData.tcl" \ "$(ROOT_DIR)/library/msgs" "$(SCRIPT_INSTALL_DIR)/msgs" install-doc: doc @@ -697,6 +696,7 @@ install-private-headers: libraries @echo "Installing private header files"; @for i in "$(GENERIC_DIR)/tclInt.h" "$(GENERIC_DIR)/tclIntDecls.h" \ "$(GENERIC_DIR)/tclIntPlatDecls.h" "$(GENERIC_DIR)/tclPort.h" \ + "$(GENERIC_DIR)/tclOOInt.h" "$(GENERIC_DIR)/tclOOIntDecls.h" \ "$(WIN_DIR)/tclWinPort.h" ; \ do \ $(COPY) "$$i" "$(PRIVATE_INCLUDE_INSTALL_DIR)"; \ @@ -706,16 +706,20 @@ install-private-headers: libraries # tcltest, i.e.: # % make test TESTFLAGS="-verbose bps -file fileName.test" -test: binaries $(TCLTEST) +test: test-tcl test-packages + +test-tcl: binaries $(TCLSH) $(CAT32) $(TEST_DLL_FILE) TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ - ./$(TCLTEST) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \ - -load "package ifneeded dde 1.4.1 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ + ./$(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.1 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ package ifneeded registry 1.3.3 [list load [file normalize ${REG_DLL_FILE}] registry]" | ./$(CAT32) -# Useful target to launch a built tcltest with the proper path,... -runtest: binaries $(TCLTEST) +# Useful target to launch a built tclsh with the proper path,... +runtest: binaries $(TCLSH) $(TEST_DLL_FILE) @TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ - ./$(TCLTEST) $(TESTFLAGS) -load "package ifneeded dde 1.4.1 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ + ./$(TCLSH) $(TESTFLAGS) -load "package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest]; \ + package ifneeded dde 1.4.1 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ package ifneeded registry 1.3.3 [list load [file normalize ${REG_DLL_FILE}] registry]" $(SCRIPT) # This target can be used to run tclsh from the build directory via @@ -738,16 +742,94 @@ Makefile: $(SRC_DIR)/Makefile.in cleanhelp: $(RM) *.hlp *.cnt *.GID *.rtf man2tcl.exe -clean: cleanhelp +clean: cleanhelp clean-packages $(RM) *.lib *.a *.exp *.dll *.$(RES) *.${OBJEXT} *~ \#* TAGS a.out - $(RM) $(TCLSH) $(TCLTEST) $(CAT32) + $(RM) $(TCLSH) $(CAT32) $(RM) *.pch *.ilk *.pdb -distclean: clean +distclean: distclean-packages clean $(RM) Makefile config.status config.cache config.log tclConfig.sh \ tcl.hpj config.status.lineno # +# Bundled package targets +# + +PKG_CFG_ARGS = @PKG_CFG_ARGS@ +PKG_DIR = ./pkgs + +packages: + @builddir=`$(CYGPATH) $$(pwd -P)`; \ + for i in $(PKGS_DIR)/*; do \ + if [ -d $$i ] ; then \ + if [ -x $$i/configure ] ; then \ + pkg=`basename $$i`; \ + mkdir -p $(PKG_DIR)/$$pkg; \ + if [ ! -f $(PKG_DIR)/$$pkg/Makefile ]; then \ + ( cd $(PKG_DIR)/$$pkg; \ + echo "Configuring package '$$i' wd = `$(CYGPATH) $$(pwd -P)`"; \ + $$i/configure --with-tcl=$$builddir --with-tclinclude=$(GENERIC_DIR_NATIVE) $(PKG_CFG_ARGS) --enable-shared --enable-threads; ) \ + fi ; \ + echo "Building package '$$pkg'"; \ + ( cd $(PKG_DIR)/$$pkg; $(MAKE); ) \ + fi; \ + fi; \ + done; \ + cd $$builddir + +install-packages: packages + @builddir=`pwd -P`; \ + for i in $(PKGS_DIR)/*; do \ + if [ -d $$i ]; then \ + pkg=`basename $$i`; \ + if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \ + echo "Installing package '$$pkg'"; \ + ( cd $(PKG_DIR)/$$pkg; $(MAKE) install "DESTDIR=$(INSTALL_ROOT)"; ) \ + fi; \ + fi; \ + done; \ + cd $$builddir + +test-packages: tcltest packages + @builddir=`pwd -P`; \ + for i in $(PKGS_DIR)/*; do \ + if [ -d $$i ]; then \ + pkg=`basename $$i`; \ + if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \ + echo "Testing package '$$pkg'"; \ + ( cd $(PKG_DIR)/$$pkg; $(MAKE) "LD_LIBRARY_PATH=$$builddir:${LD_LIBRARY_PATH}" "TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" "TCLLIBPATH=$$builddir/pkgs" test "TCLSH_PROG=$$builddir/${TCLSH}"; ) \ + fi; \ + fi; \ + done; \ + cd $$builddir + +clean-packages: + @builddir=`pwd -P`; \ + for i in $(PKGS_DIR)/*; do \ + if [ -d $$i ]; then \ + pkg=`basename $$i`; \ + if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \ + ( cd $(PKG_DIR)/$$pkg; $(MAKE) clean; ) \ + fi; \ + fi; \ + done; \ + cd $$builddir + +distclean-packages: + @builddir=`pwd -P`; \ + for i in $(PKGS_DIR)/*; do \ + if [ -d $$i ]; then \ + pkg=`basename $$i`; \ + if [ -f $(PKG_DIR)/$$pkg/Makefile ]; then \ + ( cd $(PKG_DIR)/$$pkg; $(MAKE) distclean; ) \ + fi; \ + cd $$builddir; \ + rm -rf $(PKG_DIR)/$$pkg; \ + fi; \ + done; \ + rm -rf $(PKG_DIR) + +# # Regenerate the stubs files. # @@ -761,8 +843,29 @@ genstubs: $(TCL_EXE) "$(ROOT_DIR_NATIVE)/tools/genStubs.tcl" \ "$(GENERIC_DIR_NATIVE)" \ "$(GENERIC_DIR_NATIVE)/tcl.decls" \ - "$(GENERIC_DIR_NATIVE)/tclInt.decls" \ + "$(GENERIC_DIR_NATIVE)/tclInt.decls" \ "$(GENERIC_DIR_NATIVE)/tclTomMath.decls" + $(TCL_EXE) "$(ROOT_DIR_NATIVE)/tools/genStubs.tcl" \ + "$(GENERIC_DIR_NATIVE)" \ + "$(GENERIC_DIR_NATIVE)/tclOO.decls" + +# +# This target creates the HTML folder for Tcl & Tk and places it in +# DISTDIR/html. It uses the tcltk-man2html.tcl tool from the Tcl group's tool +# workspace. It depends on the Tcl & Tk being in directories called tcl8.* & +# tk8.* up two directories from the TOOL_DIR. +# + +TOOL_DIR=$(ROOT_DIR)/tools +HTML_INSTALL_DIR=$(ROOT_DIR)/html +html: + $(MAKE) shell SCRIPT="$(TOOL_DIR)/tcltk-man2html.tcl --htmldir=$(HTML_INSTALL_DIR) --srcdir=$(ROOT_DIR)/.. $(BUILD_HTML_FLAGS)" + +html-tcl: $(TCLSH) + $(MAKE) shell SCRIPT="$(TOOL_DIR)/tcltk-man2html.tcl --htmldir=$(HTML_INSTALL_DIR) --srcdir=$(ROOT_DIR)/.. $(BUILD_HTML_FLAGS) --tcl" + +html-tk: $(TCLSH) + $(MAKE) shell SCRIPT="$(TOOL_DIR)/tcltk-man2html.tcl --htmldir=$(HTML_INSTALL_DIR) --srcdir=$(ROOT_DIR)/.. $(BUILD_HTML_FLAGS) --tk" # # The list of all the targets that do not correspond to real files. This stops @@ -1,4 +1,4 @@ -Tcl 8.5 for Windows +Tcl 8.6 for Windows 1. Introduction --------------- @@ -16,7 +16,7 @@ The information in this file is maintained on the web at: In order to compile Tcl for Windows, you need the following: - Tcl 8.5 Source Distribution (plus any patches) + Tcl 8.6 Source Distribution (plus any patches) and @@ -79,9 +79,9 @@ Use the Makefile "install" target to install Tcl. It will install it according to the prefix options you provided in the correct directory structure. -Note that in order to run tclsh85.exe, you must ensure that tcl85.dll is +Note that in order to run tclsh86.exe, you must ensure that tcl86.dll is on your path, in the system directory, or in the directory containing -tclsh85.exe. +tclsh86.exe. Note: Tcl no longer provides support for Win32s. diff --git a/win/buildall.vc.bat b/win/buildall.vc.bat index 1a0f36d..deb9e39 100644 --- a/win/buildall.vc.bat +++ b/win/buildall.vc.bat @@ -59,15 +59,15 @@ if "%INSTALLDIR%" == "" set INSTALLDIR=C:\Program Files\Tcl :: Build the normal stuff along with the help file.
::
-set OPTS=threads
-if not %SYMBOLS%.==. set OPTS=symbols,threads
-nmake -nologo -f makefile.vc release winhelp OPTS=%OPTS% %1
+set OPTS=none
+if not %SYMBOLS%.==. set OPTS=symbols
+nmake -nologo -f makefile.vc release htmlhelp OPTS=%OPTS% %1
if errorlevel 1 goto error
:: Build the static core and shell.
::
-set OPTS=static,msvcrt,threads
-if not %SYMBOLS%.==. set OPTS=symbols,static,msvcrt,threads
+set OPTS=static,msvcrt
+if not %SYMBOLS%.==. set OPTS=symbols,static,msvcrt
nmake -nologo -f makefile.vc shell OPTS=%OPTS% %1
if errorlevel 1 goto error
@@ -9,12 +9,19 @@ * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +#ifdef TCL_BROKEN_MAINARGS +/* On mingw32 and cygwin this doesn't work */ +# undef UNICODE +# undef _UNICODE +#endif + #include <stdio.h> #include <io.h> #include <string.h> +#include <tchar.h> int -main(void) +_tmain(void) { char buf[1024]; int n; diff --git a/win/configure b/win/configure index 3a77f00..3024594 100755 --- a/win/configure +++ b/win/configure @@ -309,7 +309,7 @@ ac_includes_default="\ # include <unistd.h> #endif" -ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS CC CFLAGS LDFLAGS CPPFLAGS ac_ct_CC EXEEXT OBJEXT CPP EGREP AR ac_ct_AR RANLIB ac_ct_RANLIB RC ac_ct_RC SET_MAKE TCL_THREADS CYGPATH CELIB_DIR DL_LIBS CFLAGS_DEBUG CFLAGS_OPTIMIZE CFLAGS_WARNING CFLAGS_DEFAULT LDFLAGS_DEFAULT VC_MANIFEST_EMBED_DLL VC_MANIFEST_EMBED_EXE TCL_WIN_VERSION MACHINE TCL_VERSION TCL_MAJOR_VERSION TCL_MINOR_VERSION TCL_PATCH_LEVEL TCL_LIB_FILE TCL_LIB_FLAG TCL_LIB_SPEC TCL_STUB_LIB_FILE TCL_STUB_LIB_FLAG TCL_STUB_LIB_SPEC TCL_STUB_LIB_PATH TCL_INCLUDE_SPEC TCL_BUILD_STUB_LIB_SPEC TCL_BUILD_STUB_LIB_PATH TCL_DLL_FILE TCL_SRC_DIR TCL_BIN_DIR TCL_DBGX CFG_TCL_SHARED_LIB_SUFFIX CFG_TCL_UNSHARED_LIB_SUFFIX CFG_TCL_EXPORT_FILE_SUFFIX EXTRA_CFLAGS DEPARG CC_OBJNAME CC_EXENAME LDFLAGS_DEBUG LDFLAGS_OPTIMIZE LDFLAGS_CONSOLE LDFLAGS_WINDOW STLIB_LD SHLIB_LD SHLIB_LD_LIBS SHLIB_CFLAGS SHLIB_SUFFIX TCL_SHARED_BUILD LIBS_GUI DLLSUFFIX LIBPREFIX LIBSUFFIX EXESUFFIX LIBRARIES MAKE_LIB MAKE_STUB_LIB POST_MAKE_LIB MAKE_DLL MAKE_EXE TCL_BUILD_LIB_SPEC TCL_LD_SEARCH_FLAGS TCL_NEEDS_EXP_FILE TCL_BUILD_EXP_FILE TCL_EXP_FILE TCL_LIB_VERSIONS_OK TCL_PACKAGE_PATH TCL_DDE_VERSION TCL_DDE_MAJOR_VERSION TCL_DDE_MINOR_VERSION TCL_REG_VERSION TCL_REG_MAJOR_VERSION TCL_REG_MINOR_VERSION RC_OUT RC_TYPE RC_INCLUDE RC_DEFINE RC_DEFINES RES LIBOBJS LTLIBOBJS' +ac_subst_vars='SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS CC CFLAGS LDFLAGS CPPFLAGS ac_ct_CC EXEEXT OBJEXT CPP EGREP AR ac_ct_AR RANLIB ac_ct_RANLIB RC ac_ct_RC SET_MAKE TCL_THREADS CYGPATH CELIB_DIR DL_LIBS CFLAGS_DEBUG CFLAGS_OPTIMIZE CFLAGS_WARNING ZLIB_DLL_FILE ZLIB_LIBS ZLIB_OBJS CFLAGS_DEFAULT LDFLAGS_DEFAULT VC_MANIFEST_EMBED_DLL VC_MANIFEST_EMBED_EXE TCL_WIN_VERSION MACHINE TCL_VERSION TCL_MAJOR_VERSION TCL_MINOR_VERSION TCL_PATCH_LEVEL PKG_CFG_ARGS TCL_EXE TCL_LIB_FILE TCL_LIB_FLAG TCL_STATIC_LIB_FILE TCL_STATIC_LIB_FLAG TCL_IMPORT_LIB_FILE TCL_IMPORT_LIB_FLAG TCL_LIB_SPEC TCL_STUB_LIB_FILE TCL_STUB_LIB_FLAG TCL_STUB_LIB_SPEC TCL_STUB_LIB_PATH TCL_INCLUDE_SPEC TCL_BUILD_STUB_LIB_SPEC TCL_BUILD_STUB_LIB_PATH TCL_DLL_FILE TCL_SRC_DIR TCL_BIN_DIR TCL_DBGX CFG_TCL_SHARED_LIB_SUFFIX CFG_TCL_UNSHARED_LIB_SUFFIX CFG_TCL_EXPORT_FILE_SUFFIX EXTRA_CFLAGS DEPARG CC_OBJNAME CC_EXENAME LDFLAGS_DEBUG LDFLAGS_OPTIMIZE LDFLAGS_CONSOLE LDFLAGS_WINDOW STLIB_LD SHLIB_LD SHLIB_LD_LIBS SHLIB_CFLAGS SHLIB_SUFFIX TCL_SHARED_BUILD LIBS_GUI DLLSUFFIX LIBPREFIX LIBSUFFIX EXESUFFIX LIBRARIES MAKE_LIB MAKE_STUB_LIB POST_MAKE_LIB MAKE_DLL MAKE_EXE TCL_BUILD_LIB_SPEC TCL_CC_SEARCH_FLAGS TCL_LD_SEARCH_FLAGS TCL_NEEDS_EXP_FILE TCL_BUILD_EXP_FILE TCL_EXP_FILE TCL_LIB_VERSIONS_OK TCL_PACKAGE_PATH TCL_DDE_VERSION TCL_DDE_MAJOR_VERSION TCL_DDE_MINOR_VERSION TCL_REG_VERSION TCL_REG_MAJOR_VERSION TCL_REG_MINOR_VERSION RC_OUT RC_TYPE RC_INCLUDE RC_DEFINE RC_DEFINES RES LIBOBJS LTLIBOBJS' ac_subst_files='' # Initialize some variables set by options. @@ -840,7 +840,7 @@ if test -n "$ac_init_help"; then Optional Features: --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) --enable-FEATURE[=ARG] include FEATURE [ARG=yes] - --enable-threads build with threads (default: off) + --enable-threads build with threads (default: on) --enable-shared build and link with shared libraries (default: on) --enable-64bit enable 64bit support (where applicable) --enable-wince enable Win/CE support (where applicable) @@ -1308,10 +1308,10 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu # /bin/sh. The bash shell seems to suffer from some strange failures. SHELL=/bin/sh -TCL_VERSION=8.5 +TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 -TCL_MINOR_VERSION=5 -TCL_PATCH_LEVEL=".19" +TCL_MINOR_VERSION=6 +TCL_PATCH_LEVEL=".9" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 @@ -1324,6 +1324,13 @@ TCL_REG_MAJOR_VERSION=1 TCL_REG_MINOR_VERSION=3 REGVER=$TCL_REG_MAJOR_VERSION$TCL_REG_MINOR_VERSION +PKG_CFG_ARGS=$@ + +#------------------------------------------------------------------------ +# Empty slate for bundled packages, to avoid stale configuration +#------------------------------------------------------------------------ +rm -Rf pkgs + #------------------------------------------------------------------------ # Handle the --prefix=... option #------------------------------------------------------------------------ @@ -3057,12 +3064,12 @@ if test "${enable_threads+set}" = set; then enableval="$enable_threads" tcl_ok=$enableval else - tcl_ok=no + tcl_ok=yes fi; if test "$tcl_ok" = "yes"; then - echo "$as_me:$LINENO: result: yes" >&5 -echo "${ECHO_T}yes" >&6 + echo "$as_me:$LINENO: result: yes (default)" >&5 +echo "${ECHO_T}yes (default)" >&6 TCL_THREADS=1 cat >>confdefs.h <<\_ACEOF #define TCL_THREADS 1 @@ -3076,8 +3083,8 @@ _ACEOF else TCL_THREADS=0 - echo "$as_me:$LINENO: result: no (default)" >&5 -echo "${ECHO_T}no (default)" >&6 + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 fi @@ -3271,6 +3278,11 @@ echo "${ECHO_T}$CELIB_DIR" >&6 # Set some defaults (may get changed below) EXTRA_CFLAGS="" +cat >>confdefs.h <<\_ACEOF +#define MODULE_SCOPE extern +_ACEOF + + # Extract the first word of "cygpath", so it can be a program name with args. set dummy cygpath; ac_word=$2 echo "$as_me:$LINENO: checking for $ac_word" >&5 @@ -3328,7 +3340,7 @@ cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ - #ifndef __WIN32__ + #ifndef _WIN32 #error cross-compiler #endif @@ -3451,7 +3463,7 @@ cat confdefs.h >>conftest.$ac_ext cat >>conftest.$ac_ext <<_ACEOF /* end confdefs.h. */ - #ifdef __WIN32__ + #ifdef _WIN32 #error win32 #endif @@ -3502,14 +3514,80 @@ echo "${ECHO_T}$ac_cv_win32" >&6 echo "$as_me: error: ${CC} cannot produce win32 executables." >&2;} { (exit 1); exit 1; }; } fi + + hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -mwindows -municode -Dmain=xxmain" + echo "$as_me:$LINENO: checking for working -municode linker flag" >&5 +echo $ECHO_N "checking for working -municode linker flag... $ECHO_C" >&6 +if test "${ac_cv_municode+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + + #include <windows.h> + int APIENTRY wWinMain(HINSTANCE a, HINSTANCE b, LPWSTR c, int d) {return 0;} + +int +main () +{ + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_municode=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_municode=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + +fi +echo "$as_me:$LINENO: result: $ac_cv_municode" >&5 +echo "${ECHO_T}$ac_cv_municode" >&6 + CFLAGS=$hold_cflags + if test "$ac_cv_municode" = "yes" ; then + extra_ldflags="$extra_ldflags -municode" + else + extra_cflags="$extra_cflags -DTCL_BROKEN_MAINARGS" + fi fi echo "$as_me:$LINENO: checking compiler flags" >&5 echo $ECHO_N "checking compiler flags... $ECHO_C" >&6 if test "${GCC}" = "yes" ; then SHLIB_LD="" - SHLIB_LD_LIBS="" - LIBS="-lws2_32" + SHLIB_LD_LIBS='${LIBS}' + LIBS="-lnetapi32 -lkernel32 -luser32 -ladvapi32 -luserenv -lws2_32" # mingw needs to link ole32 and oleaut32 for [send], but MSVC doesn't LIBS_GUI="-lgdi32 -lcomdlg32 -limm32 -lcomctl32 -lshell32 -luuid -lole32 -loleaut32" STLIB_LD='${AR} cr' @@ -3529,9 +3607,6 @@ echo $ECHO_N "checking compiler flags... $ECHO_C" >&6 echo "$as_me:$LINENO: result: using static flags" >&5 echo "${ECHO_T}using static flags" >&6 runtime= - MAKE_DLL="echo " - LIBSUFFIX="s\${DBGX}.a" - LIBFLAGSUFFIX="s\${DBGX}" LIBRARIES="\${STATIC_LIBRARIES}" EXESUFFIX="s\${DBGX}.exe" else @@ -3549,29 +3624,29 @@ echo "$as_me: error: ${CC} does not support the -shared option. fi runtime= - # Link with gcc since ld does not link to default libs like - # -luser32 and -lmsvcrt by default. - SHLIB_LD='${CC} -shared' - SHLIB_LD_LIBS='${LIBS}' # Add SHLIB_LD_LIBS to the Make rule, not here. - MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -o \$@ ${extra_ldflags} \ - -Wl,--out-implib,\$(patsubst %.dll,lib%.a,\$@)" - LIBSUFFIX="\${DBGX}.a" - LIBFLAGSUFFIX="\${DBGX}" EXESUFFIX="\${DBGX}.exe" LIBRARIES="\${SHARED_LIBRARIES}" fi + # Link with gcc since ld does not link to default libs like + # -luser32 and -lmsvcrt by default. + SHLIB_LD='${CC} -shared' + SHLIB_LD_LIBS='${LIBS}' + MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -o \$@ ${extra_ldflags} \ + -Wl,--out-implib,\$(patsubst %.dll,lib%.a,\$@)" # DLLSUFFIX is separate because it is the building block for # users of tclConfig.sh that may build shared or static. DLLSUFFIX="\${DBGX}.dll" + LIBSUFFIX="\${DBGX}.a" + LIBFLAGSUFFIX="\${DBGX}" SHLIB_SUFFIX=.dll EXTRA_CFLAGS="${extra_cflags}" CFLAGS_DEBUG=-g CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer" - CFLAGS_WARNING="-Wall" + CFLAGS_WARNING="-Wall -Wdeclaration-after-statement" LDFLAGS_DEBUG= LDFLAGS_OPTIMIZE= @@ -3672,24 +3747,16 @@ echo "${ECHO_T} Using 64-bit $MACHINE mode" >&6 echo "$as_me:$LINENO: result: using static flags" >&5 echo "${ECHO_T}using static flags" >&6 runtime=-MT - MAKE_DLL="echo " - LIBSUFFIX="s\${DBGX}.lib" - LIBFLAGSUFFIX="s\${DBGX}" LIBRARIES="\${STATIC_LIBRARIES}" EXESUFFIX="s\${DBGX}.exe" - SHLIB_LD_LIBS="" else # dynamic echo "$as_me:$LINENO: result: using shared flags" >&5 echo "${ECHO_T}using shared flags" >&6 runtime=-MD # Add SHLIB_LD_LIBS to the Make rule, not here. - MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -out:\$@" - LIBSUFFIX="\${DBGX}.lib" - LIBFLAGSUFFIX="\${DBGX}" - EXESUFFIX="\${DBGX}.exe" LIBRARIES="\${SHARED_LIBRARIES}" - SHLIB_LD_LIBS='${LIBS}' + EXESUFFIX="\${DBGX}.exe" case "x`echo \${VisualStudioVersion}`" in x1[4-9]*) lflags="${lflags} -nodefaultlib:libucrt.lib" @@ -3698,9 +3765,12 @@ echo "${ECHO_T}using shared flags" >&6 ;; esac fi + MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -out:\$@" # DLLSUFFIX is separate because it is the building block for # users of tclConfig.sh that may build shared or static. DLLSUFFIX="\${DBGX}.dll" + LIBSUFFIX="\${DBGX}.lib" + LIBFLAGSUFFIX="\${DBGX}" # This is a 2-stage check to make sure we have the 64-bit SDK # We have to know where the SDK is installed. @@ -3729,7 +3799,7 @@ echo "$as_me: WARNING: Could not find 64-bit $MACHINE SDK" >&2;} echo "${ECHO_T} Using 64-bit $MACHINE mode" >&6 fi - LIBS="user32.lib advapi32.lib ws2_32.lib" + LIBS="netapi32.lib kernel32.lib user32.lib advapi32.lib userenv.lib ws2_32.lib" case "x`echo \${VisualStudioVersion}`" in x1[4-9]*) @@ -3936,6 +4006,7 @@ _ACEOF fi SHLIB_LD="${LINKBIN} -dll -incremental:no ${lflags}" + SHLIB_LD_LIBS='${LIBS}' # link -lib only works when -lib is the first arg STLIB_LD="${LINKBIN} -lib ${lflags}" RC_OUT=-fo @@ -4271,6 +4342,72 @@ _ACEOF +# Cross-compiling +case ${host_alias} in +*mingw32*) + TCL_EXE="tclsh" + ;; +*) + TCL_EXE="TCL_LIBRARY=\"\${LIBRARY_DIR}\"; export TCL_LIBRARY; ./\${TCLSH}" + ;; +esac + +#------------------------------------------------------------------------ +# Add stuff for zlib; note that this is mostly done in the makefile now +# as we just assume that the platform hasn't got a usable z.lib +#------------------------------------------------------------------------ + +if test "${enable_shared+set}" = "set"; then + + enableval="$enable_shared" + tcl_ok=$enableval + +else + + tcl_ok=yes + +fi + +if test "$tcl_ok" = "yes"; then + + ZLIB_DLL_FILE=\${ZLIB_DLL_FILE} + + if test "$do64bit" != "no"; then + + if test "$GCC" == "yes"; then + + ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64/libz.dll.a + + +else + + ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64/zdll.lib + + +fi + + +else + + ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win32/zdll.lib + + +fi + + +else + + ZLIB_OBJS=\${ZLIB_OBJS} + + +fi + + +cat >>confdefs.h <<\_ACEOF +#define HAVE_ZLIB 1 +_ACEOF + + echo "$as_me:$LINENO: checking for intptr_t" >&5 echo $ECHO_N "checking for intptr_t... $ECHO_C" >&6 if test "${ac_cv_type_intptr_t+set}" = set; then @@ -4542,6 +4679,7 @@ _ACEOF fi + #-------------------------------------------------------------------- # Perform additinal compiler tests. #-------------------------------------------------------------------- @@ -4619,6 +4757,217 @@ _ACEOF fi +# See if the compiler supports intrinsics. + +echo "$as_me:$LINENO: checking for intrinsics support in compiler" >&5 +echo $ECHO_N "checking for intrinsics support in compiler... $ECHO_C" >&6 +if test "${tcl_cv_intrinsics+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +#define WIN32_LEAN_AND_MEAN +#include <windows.h> +#undef WIN32_LEAN_AND_MEAN +#include <intrin.h> + +int +main () +{ + + __cpuidex(0,0,0); + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + tcl_cv_intrinsics=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_intrinsics=no +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + +fi +echo "$as_me:$LINENO: result: $tcl_cv_intrinsics" >&5 +echo "${ECHO_T}$tcl_cv_intrinsics" >&6 +if test "$tcl_cv_intrinsics" = "yes"; then + +cat >>confdefs.h <<\_ACEOF +#define HAVE_INTRIN_H 1 +_ACEOF + +fi + +# See if the <wspiapi.h> header file is present + +echo "$as_me:$LINENO: checking for wspiapi.h" >&5 +echo $ECHO_N "checking for wspiapi.h... $ECHO_C" >&6 +if test "${tcl_cv_wspiapi_h+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +#include <wspiapi.h> + +int +main () +{ + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + tcl_cv_wspiapi_h=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_wspiapi_h=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext + +fi +echo "$as_me:$LINENO: result: $tcl_cv_wspiapi_h" >&5 +echo "${ECHO_T}$tcl_cv_wspiapi_h" >&6 +if test "$tcl_cv_wspiapi_h" = "yes"; then + +cat >>confdefs.h <<\_ACEOF +#define HAVE_WSPIAPI_H 1 +_ACEOF + +fi + +# See if declarations like FINDEX_INFO_LEVELS are +# missing from winbase.h. This is known to be +# a problem with VC++ 5.2. + +echo "$as_me:$LINENO: checking for FINDEX_INFO_LEVELS in winbase.h" >&5 +echo $ECHO_N "checking for FINDEX_INFO_LEVELS in winbase.h... $ECHO_C" >&6 +if test "${tcl_cv_findex_enums+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +#define WIN32_LEAN_AND_MEAN +#include <windows.h> +#undef WIN32_LEAN_AND_MEAN + +int +main () +{ + + FINDEX_INFO_LEVELS i; + FINDEX_SEARCH_OPS j; + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + tcl_cv_findex_enums=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +tcl_cv_findex_enums=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext + +fi +echo "$as_me:$LINENO: result: $tcl_cv_findex_enums" >&5 +echo "${ECHO_T}$tcl_cv_findex_enums" >&6 +if test "$tcl_cv_findex_enums" = "no"; then + +cat >>confdefs.h <<\_ACEOF +#define HAVE_NO_FINDEX_ENUMS 1 +_ACEOF + +fi + #-------------------------------------------------------------------- # Set the default compiler switches based on the --enable-symbols # option. This macro depends on C flags, and should be called @@ -4775,12 +5124,6 @@ eval "TCL_SRC_DIR=\"`cd $srcdir/..; $CYGPATH $(pwd)`\"" eval "TCL_DLL_FILE=tcl${VER}${DLLSUFFIX}" -eval "TCL_LIB_FILE=${LIBPREFIX}tcl$VER${LIBSUFFIX}" - -eval "TCL_LIB_FLAG=\"-ltcl${VER}${LIBFLAGSUFFIX}\"" -eval "TCL_BUILD_LIB_SPEC=\"-L`$CYGPATH $(pwd)` ${TCL_LIB_FLAG}\"" -eval "TCL_LIB_SPEC=\"-L${libdir} ${TCL_LIB_FLAG}\"" - eval "TCL_STUB_LIB_FILE=\"${LIBPREFIX}tclstub${VER}${LIBSUFFIX}\"" eval "TCL_STUB_LIB_FLAG=\"-ltclstub${VER}${LIBFLAGSUFFIX}\"" eval "TCL_BUILD_STUB_LIB_SPEC=\"-L`$CYGPATH $(pwd)` ${TCL_STUB_LIB_FLAG}\"" @@ -4788,6 +5131,10 @@ eval "TCL_STUB_LIB_SPEC=\"-L${libdir} ${TCL_STUB_LIB_FLAG}\"" eval "TCL_BUILD_STUB_LIB_PATH=\"`$CYGPATH $(pwd)`/${TCL_STUB_LIB_FILE}\"" eval "TCL_STUB_LIB_PATH=\"${libdir}/${TCL_STUB_LIB_FILE}\"" +eval "TCL_LIB_FILE=\"${LIBPREFIX}tcl${VER}${LIBSUFFIX}\"" +eval "TCL_BUILD_LIB_SPEC=\"-L`$CYGPATH $(pwd)` -ltcl${VER}${FLAGSUFFIX}\"" +eval "TCL_LIB_SPEC=\"-L${libdir} -ltcl${VER}${FLAGSUFFIX}\"" + # Install time header dir can be set via --includedir eval "TCL_INCLUDE_SPEC=\"-I${includedir}\"" @@ -4853,6 +5200,12 @@ TCL_WIN_VERSION="$TCL_VERSION.$TCL_RELEASE_LEVEL.`echo $TCL_PATCH_LEVEL | tr -d + + + + + + # empty on win @@ -4918,6 +5271,7 @@ TCL_WIN_VERSION="$TCL_VERSION.$TCL_RELEASE_LEVEL.`echo $TCL_PATCH_LEVEL | tr -d + # win only @@ -5595,6 +5949,9 @@ s,@DL_LIBS@,$DL_LIBS,;t t s,@CFLAGS_DEBUG@,$CFLAGS_DEBUG,;t t s,@CFLAGS_OPTIMIZE@,$CFLAGS_OPTIMIZE,;t t s,@CFLAGS_WARNING@,$CFLAGS_WARNING,;t t +s,@ZLIB_DLL_FILE@,$ZLIB_DLL_FILE,;t t +s,@ZLIB_LIBS@,$ZLIB_LIBS,;t t +s,@ZLIB_OBJS@,$ZLIB_OBJS,;t t s,@CFLAGS_DEFAULT@,$CFLAGS_DEFAULT,;t t s,@LDFLAGS_DEFAULT@,$LDFLAGS_DEFAULT,;t t s,@VC_MANIFEST_EMBED_DLL@,$VC_MANIFEST_EMBED_DLL,;t t @@ -5605,8 +5962,14 @@ s,@TCL_VERSION@,$TCL_VERSION,;t t s,@TCL_MAJOR_VERSION@,$TCL_MAJOR_VERSION,;t t s,@TCL_MINOR_VERSION@,$TCL_MINOR_VERSION,;t t s,@TCL_PATCH_LEVEL@,$TCL_PATCH_LEVEL,;t t +s,@PKG_CFG_ARGS@,$PKG_CFG_ARGS,;t t +s,@TCL_EXE@,$TCL_EXE,;t t s,@TCL_LIB_FILE@,$TCL_LIB_FILE,;t t s,@TCL_LIB_FLAG@,$TCL_LIB_FLAG,;t t +s,@TCL_STATIC_LIB_FILE@,$TCL_STATIC_LIB_FILE,;t t +s,@TCL_STATIC_LIB_FLAG@,$TCL_STATIC_LIB_FLAG,;t t +s,@TCL_IMPORT_LIB_FILE@,$TCL_IMPORT_LIB_FILE,;t t +s,@TCL_IMPORT_LIB_FLAG@,$TCL_IMPORT_LIB_FLAG,;t t s,@TCL_LIB_SPEC@,$TCL_LIB_SPEC,;t t s,@TCL_STUB_LIB_FILE@,$TCL_STUB_LIB_FILE,;t t s,@TCL_STUB_LIB_FLAG@,$TCL_STUB_LIB_FLAG,;t t @@ -5648,6 +6011,7 @@ s,@POST_MAKE_LIB@,$POST_MAKE_LIB,;t t s,@MAKE_DLL@,$MAKE_DLL,;t t s,@MAKE_EXE@,$MAKE_EXE,;t t s,@TCL_BUILD_LIB_SPEC@,$TCL_BUILD_LIB_SPEC,;t t +s,@TCL_CC_SEARCH_FLAGS@,$TCL_CC_SEARCH_FLAGS,;t t s,@TCL_LD_SEARCH_FLAGS@,$TCL_LD_SEARCH_FLAGS,;t t s,@TCL_NEEDS_EXP_FILE@,$TCL_NEEDS_EXP_FILE,;t t s,@TCL_BUILD_EXP_FILE@,$TCL_BUILD_EXP_FILE,;t t diff --git a/win/configure.in b/win/configure.in index 12c81ed..511cb39 100644 --- a/win/configure.in +++ b/win/configure.in @@ -11,10 +11,10 @@ AC_PREREQ(2.59) # /bin/sh. The bash shell seems to suffer from some strange failures. SHELL=/bin/sh -TCL_VERSION=8.5 +TCL_VERSION=8.6 TCL_MAJOR_VERSION=8 -TCL_MINOR_VERSION=5 -TCL_PATCH_LEVEL=".19" +TCL_MINOR_VERSION=6 +TCL_PATCH_LEVEL=".9" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 @@ -27,6 +27,13 @@ TCL_REG_MAJOR_VERSION=1 TCL_REG_MINOR_VERSION=3 REGVER=$TCL_REG_MAJOR_VERSION$TCL_REG_MINOR_VERSION +PKG_CFG_ARGS=$@ + +#------------------------------------------------------------------------ +# Empty slate for bundled packages, to avoid stale configuration +#------------------------------------------------------------------------ +rm -Rf pkgs + #------------------------------------------------------------------------ # Handle the --prefix=... option #------------------------------------------------------------------------ @@ -98,6 +105,43 @@ SC_ENABLE_SHARED SC_CONFIG_CFLAGS +# Cross-compiling +case ${host_alias} in +*mingw32*) + TCL_EXE="tclsh" + ;; +*) + TCL_EXE="TCL_LIBRARY=\"\${LIBRARY_DIR}\"; export TCL_LIBRARY; ./\${TCLSH}" + ;; +esac + +#------------------------------------------------------------------------ +# Add stuff for zlib; note that this is mostly done in the makefile now +# as we just assume that the platform hasn't got a usable z.lib +#------------------------------------------------------------------------ + +AS_IF([test "${enable_shared+set}" = "set"], [ + enableval="$enable_shared" + tcl_ok=$enableval +], [ + tcl_ok=yes +]) +AS_IF([test "$tcl_ok" = "yes"], [ + AC_SUBST(ZLIB_DLL_FILE,[\${ZLIB_DLL_FILE}]) + AS_IF([test "$do64bit" != "no"], [ + AS_IF([test "$GCC" == "yes"],[ + AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64/libz.dll.a]) + ], [ + AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64/zdll.lib]) + ]) + ], [ + AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win32/zdll.lib]) + ]) +], [ + AC_SUBST(ZLIB_OBJS,[\${ZLIB_OBJS}]) +]) +AC_DEFINE(HAVE_ZLIB, 1, [Is there an installed zlib?]) + AC_CHECK_TYPE([intptr_t], [ AC_DEFINE([HAVE_INTPTR_T], 1, [Do we have the intptr_t type?])], [ AC_CACHE_CHECK([for pointer-size signed integer type], tcl_cv_intptr_t, [ @@ -129,6 +173,7 @@ AC_CHECK_TYPE([uintptr_t], [ type wide enough to hold a pointer.]) fi ]) + #-------------------------------------------------------------------- # Perform additinal compiler tests. #-------------------------------------------------------------------- @@ -156,6 +201,65 @@ if test "$tcl_cv_findex_enums" = "no"; then [Defined when enums are missing from winbase.h]) fi +# See if the compiler supports intrinsics. + +AC_CACHE_CHECK(for intrinsics support in compiler, + tcl_cv_intrinsics, +AC_TRY_LINK([ +#define WIN32_LEAN_AND_MEAN +#include <windows.h> +#undef WIN32_LEAN_AND_MEAN +#include <intrin.h> +], +[ + __cpuidex(0,0,0); +], + tcl_cv_intrinsics=yes, + tcl_cv_intrinsics=no) +) +if test "$tcl_cv_intrinsics" = "yes"; then + AC_DEFINE(HAVE_INTRIN_H, 1, + [Defined when the compilers supports intrinsics]) +fi + +# See if the <wspiapi.h> header file is present + +AC_CACHE_CHECK(for wspiapi.h, + tcl_cv_wspiapi_h, +AC_TRY_COMPILE([ +#include <wspiapi.h> +], [], + tcl_cv_wspiapi_h=yes, + tcl_cv_wspiapi_h=no) +) +if test "$tcl_cv_wspiapi_h" = "yes"; then + AC_DEFINE(HAVE_WSPIAPI_H, 1, + [Defined when wspiapi.h exists]) +fi + +# See if declarations like FINDEX_INFO_LEVELS are +# missing from winbase.h. This is known to be +# a problem with VC++ 5.2. + +AC_CACHE_CHECK(for FINDEX_INFO_LEVELS in winbase.h, + tcl_cv_findex_enums, +AC_TRY_COMPILE([ +#define WIN32_LEAN_AND_MEAN +#include <windows.h> +#undef WIN32_LEAN_AND_MEAN +], +[ + FINDEX_INFO_LEVELS i; + FINDEX_SEARCH_OPS j; +], + tcl_cv_findex_enums=yes, + tcl_cv_findex_enums=no) +) +if test "$tcl_cv_findex_enums" = "no"; then + AC_DEFINE(HAVE_NO_FINDEX_ENUMS, 1, + [Defined when enums are missing from winbase.h]) +fi + #-------------------------------------------------------------------- # Set the default compiler switches based on the --enable-symbols # option. This macro depends on C flags, and should be called @@ -190,12 +294,6 @@ eval "TCL_SRC_DIR=\"`cd $srcdir/..; $CYGPATH $(pwd)`\"" eval "TCL_DLL_FILE=tcl${VER}${DLLSUFFIX}" -eval "TCL_LIB_FILE=${LIBPREFIX}tcl$VER${LIBSUFFIX}" - -eval "TCL_LIB_FLAG=\"-ltcl${VER}${LIBFLAGSUFFIX}\"" -eval "TCL_BUILD_LIB_SPEC=\"-L`$CYGPATH $(pwd)` ${TCL_LIB_FLAG}\"" -eval "TCL_LIB_SPEC=\"-L${libdir} ${TCL_LIB_FLAG}\"" - eval "TCL_STUB_LIB_FILE=\"${LIBPREFIX}tclstub${VER}${LIBSUFFIX}\"" eval "TCL_STUB_LIB_FLAG=\"-ltclstub${VER}${LIBFLAGSUFFIX}\"" eval "TCL_BUILD_STUB_LIB_SPEC=\"-L`$CYGPATH $(pwd)` ${TCL_STUB_LIB_FLAG}\"" @@ -203,6 +301,10 @@ eval "TCL_STUB_LIB_SPEC=\"-L${libdir} ${TCL_STUB_LIB_FLAG}\"" eval "TCL_BUILD_STUB_LIB_PATH=\"`$CYGPATH $(pwd)`/${TCL_STUB_LIB_FILE}\"" eval "TCL_STUB_LIB_PATH=\"${libdir}/${TCL_STUB_LIB_FILE}\"" +eval "TCL_LIB_FILE=\"${LIBPREFIX}tcl${VER}${LIBSUFFIX}\"" +eval "TCL_BUILD_LIB_SPEC=\"-L`$CYGPATH $(pwd)` -ltcl${VER}${FLAGSUFFIX}\"" +eval "TCL_LIB_SPEC=\"-L${libdir} -ltcl${VER}${FLAGSUFFIX}\"" + # Install time header dir can be set via --includedir eval "TCL_INCLUDE_SPEC=\"-I${includedir}\"" @@ -265,9 +367,15 @@ AC_SUBST(TCL_VERSION) AC_SUBST(TCL_MAJOR_VERSION) AC_SUBST(TCL_MINOR_VERSION) AC_SUBST(TCL_PATCH_LEVEL) +AC_SUBST(PKG_CFG_ARGS) +AC_SUBST(TCL_EXE) AC_SUBST(TCL_LIB_FILE) AC_SUBST(TCL_LIB_FLAG) +AC_SUBST(TCL_STATIC_LIB_FILE) +AC_SUBST(TCL_STATIC_LIB_FLAG) +AC_SUBST(TCL_IMPORT_LIB_FILE) +AC_SUBST(TCL_IMPORT_LIB_FLAG) # empty on win AC_SUBST(TCL_LIB_SPEC) AC_SUBST(TCL_STUB_LIB_FILE) @@ -325,6 +433,7 @@ AC_SUBST(MAKE_EXE) # empty on win, but needs sub'ing AC_SUBST(TCL_BUILD_LIB_SPEC) +AC_SUBST(TCL_CC_SEARCH_FLAGS) AC_SUBST(TCL_LD_SEARCH_FLAGS) AC_SUBST(TCL_NEEDS_EXP_FILE) AC_SUBST(TCL_BUILD_EXP_FILE) diff --git a/win/makefile.bc b/win/makefile.bc deleted file mode 100644 index 8f337e3..0000000 --- a/win/makefile.bc +++ /dev/null @@ -1,597 +0,0 @@ -#
-# Makefile for Borland C++ 5.5 (or C++ Builder 5), adapted from the makefile
-# for Visual C++ that came with tcl 8.3.3
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# Copyright (c) 1995-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
-
-# TIP #59 information.
-#
-# This makefile does not set the following configuration cpp
-# defines. Behind the defines are the makefile variables listed to set
-# to -D... when that feature is enabled.
-#
-# - TCL_CFG_PROFILED PROFDEFINES
-# - TCL_CFG_OPTIMIZED OPTDEFINES
-# - TCL_CFG_DO64BIT SIXFOURDEFINES
-
-# Have a look at the complete description on how to build and test Tcl with
-# the current Borland compilers at www.ratiosoft.com/tcl/borland.
-#
-# Usage:
-# - Adapt the paths below to match your compiler's location
-# - Make sure the compiler's bin directory is on your path
-# - Open a console
-# - To make a debug version enter
-# make -fmakefile.bc -DNODEBUG=0 xxx
-# where 'xxx' is the target you want (e.g. 'all', 'test', ...)
-# Please note: I omitted the 'd' suffix for debug versions because Tcl
-# will always call tclpip83.dll and not tclpip83d.dll, causing an error.
-# ^
-# Besides, the debug version goes into a separate directory, so there
-# should be no problem having DLLs and EXEs with the same name.
-# If you prefer your debug version having the 'd' suffix just uncomment
-# the line
-# #DBGX = d
-#
-# - To make a 'normal' version enter
-# make -fmakefile.bc xxx
-# where 'xxx' is the target you want (e.g. 'all', 'test', ...)
-#
-# DISCLAIMER:
-# This makefile has an experimental status - that is those targets which
-# have been modified do in fact compile and link with Borland's C++
-# Builder 5 and with the free Borland compiler (Borland C++ 5.5).
-# However the author assumes no responsiblity for any effect which the use of
-# this makefile or of the resulting programs might have on your system.
-#
-# 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.
-#
-# May 2001, H. Giese (hgiese@ratiosoft.com)
-#
-
-# Does not depend on the presence of any environment variables in
-# order to compile tcl; all needed information is derived from
-# location of the compiler directories.
-
-#
-# Project directories
-#
-# ROOT = top of source tree
-#
-# TOOLS32 = location of Borland development tools.
-#
-# INSTALLDIR = where the install-targets should copy the binaries and
-# support files
-#
-
-ROOT = ..
-INSTALLDIR = c:\program files\tcl
-
-# If you have C++ Builder 5 or the free Borland C++ 5.5 compiler
-# adapt the following paths as appropriate for your system
-TOOLS32 = c:\dev\bcc55
-TOOLS32_rc = c:\dev\bcc55
-#TOOLS32 = c:\bc55
-#TOOLS32_rc = c:\bc55
-
-cc32 = "$(TOOLS32)\bin\bcc32.exe"
-link32 = "$(TOOLS32)\bin\ilink32.exe"
-lib32 = "$(TOOLS32)\bin\tlib.exe"
-rc32 = "$(TOOLS32_rc)\bin\brcc32.exe"
-include32 = -I"$(TOOLS32)\include"
-libpath32 = -L"$(TOOLS32)\lib"
-
-# Uncomment the following line to compile with thread support
-#THREADDEFINES = -DTCL_THREADS=1
-
-# Allow definition of NDEBUG via command line
-# Set NODEBUG to 0 to compile with symbols
-!if !defined(NODEBUG)
-NODEBUG = 1
-!endif
-
-# CFG_ENCODING=encoding
-# name of encoding for configuration information. Defaults
-# to cp1252
-!if !defined(CFG_ENCODING)
-CFG_ENCODING = \"cp1252\"
-!endif
-
-# The following defines can be used to control the amount of debugging
-# code that is added to the compilation.
-#
-# -DTCL_MEM_DEBUG Enables the debugging memory allocator.
-# -DTCL_COMPILE_DEBUG Enables byte compilation logging.
-# -DTCL_COMPILE_STATS Enables byte compilation statistics gathering.
-# -DUSE_TCLALLOC=0 Disables the Tcl memory allocator in favor
-# of the native malloc implementation. This is
-# needed when using Purify.
-#
-#DEBUGDEFINES = -DTCL_MEM_DEBUG -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS
-#DEBUGDEFINES = -DUSE_TCLALLOC=0
-
-######################################################################
-# Do not modify below this line
-######################################################################
-
-NAMEPREFIX = tcl
-STUBPREFIX = $(NAMEPREFIX)stub
-DOTVERSION = 8.5
-VERSION = 85
-
-DDEVERSION = 14
-DDEDOTVERSION = 1.4
-
-REGVERSION = 13
-REGDOTVERSION = 1.3
-
-BINROOT = ..
-!IF "$(NODEBUG)" == "1"
-TMPDIRNAME = Release
-DBGX =
-SYMDEFINES = -DNDEBUG
-!ELSE
-TMPDIRNAME = Debug
-#DBGX = d
-DBGX =
-SYMDEFINES = -DTCL_CFG_DEBUG
-!ENDIF
-TMPDIR = $(BINROOT)\$(TMPDIRNAME)
-OUTDIRNAME = $(TMPDIRNAME)
-OUTDIR = $(TMPDIR)
-
-TCLLIB = $(OUTDIR)\$(NAMEPREFIX)$(VERSION)$(DBGX).lib
-TCLDLLNAME = $(NAMEPREFIX)$(VERSION)$(DBGX).dll
-TCLDLL = $(OUTDIR)\$(TCLDLLNAME)
-
-TCLSTUBLIBNAME = $(STUBPREFIX)$(VERSION)$(DBGX).lib
-TCLSTUBLIB = $(OUTDIR)\$(TCLSTUBLIBNAME)
-
-TCLPLUGINLIB = $(OUTDIR)\$(NAMEPREFIX)$(VERSION)p$(DBGX).lib
-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
-TCLDDEDLL = $(OUTDIR)\$(TCLDDEDLLNAME)
-TCLTEST = $(OUTDIR)\$(NAMEPREFIX)test.exe
-CAT32 = $(TMPDIR)\cat32.exe
-RMDIR = .\rmd.bat
-MKDIR = .\mkd.bat
-RM = del
-
-LIB_INSTALL_DIR = $(INSTALLDIR)\lib
-BIN_INSTALL_DIR = $(INSTALLDIR)\bin
-SCRIPT_INSTALL_DIR = $(INSTALLDIR)\lib\tcl$(DOTVERSION)
-INCLUDE_INSTALL_DIR = $(INSTALLDIR)\include
-
-TCLSHOBJS = \
- $(TMPDIR)\tclAppInit.obj
-
-TCLTESTOBJS = \
- $(TMPDIR)\tclTest.obj \
- $(TMPDIR)\tclTestObj.obj \
- $(TMPDIR)\tclTestProcBodyObj.obj \
- $(TMPDIR)\tclThreadTest.obj \
- $(TMPDIR)\tclWinTest.obj \
- $(TMPDIR)\testMain.obj
-
-TCLOBJS = \
- $(TMPDIR)\regcomp.obj \
- $(TMPDIR)\regexec.obj \
- $(TMPDIR)\regfree.obj \
- $(TMPDIR)\regerror.obj \
- $(TMPDIR)\tclAlloc.obj \
- $(TMPDIR)\tclAsync.obj \
- $(TMPDIR)\tclBasic.obj \
- $(TMPDIR)\tclBinary.obj \
- $(TMPDIR)\tclCkalloc.obj \
- $(TMPDIR)\tclClock.obj \
- $(TMPDIR)\tclCmdAH.obj \
- $(TMPDIR)\tclCmdIL.obj \
- $(TMPDIR)\tclCmdMZ.obj \
- $(TMPDIR)\tclCompCmds.obj \
- $(TMPDIR)\tclCompExpr.obj \
- $(TMPDIR)\tclCompile.obj \
- $(TMPDIR)\tclConfig.obj \
- $(TMPDIR)\tclDate.obj \
- $(TMPDIR)\tclDictObj.obj \
- $(TMPDIR)\tclEncoding.obj \
- $(TMPDIR)\tclEnv.obj \
- $(TMPDIR)\tclEvent.obj \
- $(TMPDIR)\tclExecute.obj \
- $(TMPDIR)\tclFCmd.obj \
- $(TMPDIR)\tclFileName.obj \
- $(TMPDIR)\tclGet.obj \
- $(TMPDIR)\tclHash.obj \
- $(TMPDIR)\tclHistory.obj \
- $(TMPDIR)\tclIndexObj.obj \
- $(TMPDIR)\tclInterp.obj \
- $(TMPDIR)\tclIO.obj \
- $(TMPDIR)\tclIOCmd.obj \
- $(TMPDIR)\tclIOGT.obj \
- $(TMPDIR)\tclIOSock.obj \
- $(TMPDIR)\tclIOUtil.obj \
- $(TMPDIR)\tclLink.obj \
- $(TMPDIR)\tclLiteral.obj \
- $(TMPDIR)\tclListObj.obj \
- $(TMPDIR)\tclLoad.obj \
- $(TMPDIR)\tclMain.obj \
- $(TMPDIR)\tclNamesp.obj \
- $(TMPDIR)\tclNotify.obj \
- $(TMPDIR)\tclObj.obj \
- $(TMPDIR)\tclPanic.obj \
- $(TMPDIR)\tclParse.obj \
- $(TMPDIR)\tclPipe.obj \
- $(TMPDIR)\tclPkg.obj \
- $(TMPDIR)\tclPkgConfig.obj \
- $(TMPDIR)\tclPosixStr.obj \
- $(TMPDIR)\tclPreserve.obj \
- $(TMPDIR)\tclProc.obj \
- $(TMPDIR)\tclRegexp.obj \
- $(TMPDIR)\tclResolve.obj \
- $(TMPDIR)\tclResult.obj \
- $(TMPDIR)\tclScan.obj \
- $(TMPDIR)\tclStringObj.obj \
- $(TMPDIR)\tclStubInit.obj \
- $(TMPDIR)\tclStubLib.obj \
- $(TMPDIR)\tclThread.obj \
- $(TMPDIR)\tclThreadJoin.obj \
- $(TMPDIR)\tclTimer.obj \
- $(TMPDIR)\tclTrace.obj \
- $(TMPDIR)\tclUtf.obj \
- $(TMPDIR)\tclUtil.obj \
- $(TMPDIR)\tclVar.obj \
- $(TMPDIR)\tclWin32Dll.obj \
- $(TMPDIR)\tclWinChan.obj \
- $(TMPDIR)\tclWinConsole.obj \
- $(TMPDIR)\tclWinSerial.obj \
- $(TMPDIR)\tclWinError.obj \
- $(TMPDIR)\tclWinFCmd.obj \
- $(TMPDIR)\tclWinFile.obj \
- $(TMPDIR)\tclWinInit.obj \
- $(TMPDIR)\tclWinLoad.obj \
- $(TMPDIR)\tclWinNotify.obj \
- $(TMPDIR)\tclWinPipe.obj \
- $(TMPDIR)\tclWinSock.obj \
- $(TMPDIR)\tclWinThrd.obj \
- $(TMPDIR)\tclWinTime.obj
-
-TCLSTUBOBJS = $(TMPDIR)\tclStubLib.obj
-
-WINDIR = $(ROOT)\win
-GENERICDIR = $(ROOT)\generic
-
-TCL_INCLUDES = -I"$(WINDIR)" -I"$(GENERICDIR)"
-TCL_DEFINES = $(DEBUGDEFINES) $(THREADDEFINES) $(SYMDEFINES) \
- $(PROFDEFINES) $(OPTDEFINES) $(SIXFOURDEFINES) \
- -DTCL_CFGVAL_ENCODING=${CFG_ENCODING}
-
-######################################################################
-# Compiler flags
-######################################################################
-
-!IF "$(NODEBUG)" == "1"
-# these macros cause maximum optimization and no symbols
-cdebug = -v- -vi- -O2 -D_DEBUG
-!ELSE
-# these macros enable debugging
-cdebug = -k -Od -r- -v -vi- -y
-!ENDIF
-
-SYSDEFINES = _MT;NO_STRICT;_NO_VCL
-
-# declarations common to all compiler options
-cbase = -c -q -3 -a4 -g0 -tWM -Ve -Vx -X-
-WARNINGS = -w-rch -w-pch -w-par -w-dup -w-pro -w-dpu
-
-ccons = -tWC
-
-INCLUDEPATH = $(include32) $(TCL_INCLUDES)
-
-CFLAGS = $(cdebug) $(cbase) $(INCLUDEPATH) $(WARNINGS) -D$(SYSDEFINES)
-TCL_CFLAGS = $(CFLAGS) $(TCL_DEFINES)
-CONS_CFLAGS = $(CFLAGS) $(TCL_DEFINES) $(ccons)
-
-######################################################################
-# Linker flags
-######################################################################
-
-!IF "$(NODEBUG)" == "1"
-ldebug =
-!ELSE
-ldebug = -v
-!ENDIF
-
-# declarations common to all linker options
-LNFLAGS = -D"" -Gn -I$(TMPDIR) -x $(ldebug) $(libpath32)
-# -Gi: create lib file (is -Gl in doc)
-# -aa: Windows app, -ap: Windows console app
-LNFLAGS_DLL = -ap -Gi -Tpd
-LNFLAGS_CONS = -ap -Tpe
-
-LNLIBS = import32 cw32mt
-
-
-######################################################################
-# Project specific targets
-######################################################################
-
-release: setup $(TCLSH) dlls
-dlls: setup $(TCLPIPEDLL) $(TCLREGDLL) $(TCLDDEDLL)
-all: setup $(TCLSH) dlls $(CAT32)
-tcltest: setup $(TCLTEST) dlls $(CAT32)
-plugin: setup $(TCLPLUGINDLL) $(TCLSHP)
-install: install-binaries install-libraries
-
-test: setup $(TCLTEST) dlls $(CAT32)
- set TCL_LIBRARY=$(ROOT)/library
- $(TCLTEST) $(ROOT)/tests/all.tcl
-
-setup:
- @if not exist $(OUT_DIR)\nul mkdir $(OUT_DIR) &\
- echo *** Created directory '$(OUT_DIR)'
- @if not exist $(TMP_DIR)\nul mkdir $(TMP_DIR) &\
- echo *** Created directory '$(TMP_DIR)'
-
-
-$(TCLLIB): $(TCLDLL)
-
-$(TCLDLL): $(TCLOBJS) $(TMPDIR)\$(NAMEPREFIX).res
- $(link32) $(ldebug) $(LNFLAGS) $(LNFLAGS_DLL) $(TOOLS32)\lib\c0d32 @&&!
- $(TCLOBJS), $@, -x, $(LNLIBS),, $(TMPDIR)\$(NAMEPREFIX).res
-!
-
-$(TCLSTUBLIB): $(TCLSTUBOBJS)
- $(lib32) /u $@ $(TCLSTUBOBJS)
-
-$(TCLPLUGINLIB): $(TCLPLUGINDLL)
-
-$(TCLPLUGINDLL): $(TCLOBJS) $(TMPDIR)\tcl.res
- $(link32) $(ldebug) $(dlllflags) \
- -out:$@ $(TMPDIR)\tcl.res $(guilibsdll) @&&!
-$(TCLOBJS)
-!
-
-$(TCLSH): $(TCLSHOBJS) $(TCLLIB) $(TMPDIR)\$(NAMEPREFIX)sh.res
- $(link32) $(ldebug) -S:2400000 $(LNFLAGS) $(LNFLAGS_CONS) $(TOOLS32)\lib\c0x32 @&&!
- $(TCLSHOBJS), $@, -x, $(LNLIBS) $(TCLLIB),, $(TMPDIR)\$(NAMEPREFIX)sh.res
-!
-
-$(TCLSHP): $(TCLSHOBJS) $(TCLPLUGINLIB) $(TMPDIR)\tclsh.res
- $(link32) $(ldebug) $(conlflags) $(TMPDIR)\tclsh.res -stack:2300000 \
- -out:$@ $(conlibsdll) $(TCLPLUGINLIB) $(TCLSHOBJS)
-
-$(TCLTEST): $(TCLTESTOBJS) $(TCLLIB) $(TMPDIR)\$(NAMEPREFIX)sh.res
- $(link32) $(ldebug) -S:2400000 $(LNFLAGS) $(LNFLAGS_CONS) $(TOOLS32)\lib\c0x32 @&&!
- $(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),, \
- $(TMPDIR)\$(NAMEPREFIX).res
-
-$(TCLREGDLL): $(TMPDIR)\tclWinReg.obj $(TCLSTUBLIB)
- $(link32) $(ldebug) $(LNFLAGS) $(LNFLAGS_DLL) $(TOOLS32)\lib\c0d32 \
- $(TMPDIR)\tclWinReg.obj, $@, -x, $(LNLIBS) $(TCLSTUBLIB),, \
- $(TMPDIR)\$(NAMEPREFIX).res
-
-$(CAT32): $(WINDIR)\cat.c
- $(cc32) $(CONS_CFLAGS) -o$(TMPDIR)\cat.obj $?
- $(link32) $(ldebug) $(LNFLAGS) $(LNFLAGS_CONS) $(TOOLS32)\lib\c0x32 \
- $(TMPDIR)\cat.obj, $@, -x, $(LNLIBS),,
-
-install-binaries: $(TCLSH)
- $(MKDIR) "$(BIN_INSTALL_DIR)"
- $(MKDIR) "$(LIB_INSTALL_DIR)"
- @echo Installing $(TCLDLLNAME)
- @copy "$(TCLDLL)" "$(BIN_INSTALL_DIR)"
- @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)"
-
-install-libraries:
- -@$(MKDIR) "$(LIB_INSTALL_DIR)"
- -@$(MKDIR) "$(INCLUDE_INSTALL_DIR)"
- -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)"
- @echo Installing http1.0
- -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http1.0"
- -@copy "$(ROOT)\library\http1.0\http.tcl" "$(SCRIPT_INSTALL_DIR)\http1.0"
- -@copy "$(ROOT)\library\http1.0\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http1.0"
- @echo Installing http2.7
- -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http2.7"
- -@copy "$(ROOT)\library\http\http.tcl" "$(SCRIPT_INSTALL_DIR)\http2.7"
- -@copy "$(ROOT)\library\http\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http2.7"
- @echo Installing opt0.4
- -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\opt0.4"
- -@copy "$(ROOT)\library\opt\optparse.tcl" "$(SCRIPT_INSTALL_DIR)\opt0.4"
- -@copy "$(ROOT)\library\opt\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\opt0.4"
- @echo Installing msgcat1.5
- -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\msgcat1.5"
- -@copy "$(ROOT)\library\msgcat\msgcat.tcl" "$(SCRIPT_INSTALL_DIR)\msgcat1.5"
- -@copy "$(ROOT)\library\msgcat\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\msgcat1.5"
- @echo Installing tcltest2.5
- -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\tcltest2.5"
- -@copy "$(ROOT)\library\tcltest\tcltest.tcl" "$(SCRIPT_INSTALL_DIR)\tcltest2.5"
- -@copy "$(ROOT)\library\tcltest\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\tcltest2.5"
- @echo Installing platform1.0
- -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\platform1.0"
- -@copy "$(ROOT)\library\platform\platform.tcl" "$(SCRIPT_INSTALL_DIR)\platform1.0"
- -@copy "$(ROOT)\library\platform\shell.tcl" "$(SCRIPT_INSTALL_DIR)\platform1.0"
- -@copy "$(ROOT)\library\platform\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\platform1.0"
- @echo Installing $(TCLDDEDLLNAME)
- -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\dde1.3"
- -@copy "$(TCLDDEDLL)" "$(SCRIPT_INSTALL_DIR)\dde1.3"
- -@copy "$(ROOT)\library\dde\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\dde1.3"
- @echo Installing $(TCLREGDLLNAME)
- -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\reg1.2"
- -@copy "$(TCLREGDLL)" "$(SCRIPT_INSTALL_DIR)\reg1.2"
- -@copy "$(ROOT)\library\reg\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\reg1.2"
- @echo Installing encoding files
- -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\encoding"
- -@copy "$(ROOT)\library\encoding\*.enc" "$(SCRIPT_INSTALL_DIR)\encoding"
- @echo Installing library files
- -@copy "$(GENERICDIR)\tcl.h" "$(INCLUDE_INSTALL_DIR)"
- -@copy "$(GENERICDIR)\tclDecls.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)"
- -@copy "$(ROOT)\library\parray.tcl" "$(SCRIPT_INSTALL_DIR)"
- -@copy "$(ROOT)\library\safe.tcl" "$(SCRIPT_INSTALL_DIR)"
- -@copy "$(ROOT)\library\tclIndex" "$(SCRIPT_INSTALL_DIR)"
- -@copy "$(ROOT)\library\package.tcl" "$(SCRIPT_INSTALL_DIR)"
- -@copy "$(ROOT)\library\word.tcl" "$(SCRIPT_INSTALL_DIR)"
- -@copy "$(ROOT)\library\auto.tcl" "$(SCRIPT_INSTALL_DIR)"
-
-#
-# Regenerate the stubs files.
-#
-
-genstubs:
- tclsh$(VERSION) $(ROOT)\tools\genStubs.tcl $(GENERICDIR) \
- $(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
- $(cc32) -DBUILD_tcl $(TCL_CFLAGS) -o$(TMPDIR)\$@ $?
-
-$(TMPDIR)\testMain.obj: $(WINDIR)\tclAppInit.c
- $(cc32) $(TCL_CFLAGS) -DTCL_TEST -o$(TMPDIR)\testMain.obj $?
-
-$(TMPDIR)\tclTest.obj: $(GENERICDIR)\tclTest.c
- $(cc32) $(TCL_CFLAGS) -o$(TMPDIR)\$@ $?
-
-$(TMPDIR)\tclTestObj.obj: $(GENERICDIR)\tclTestObj.c
- $(cc32) $(TCL_CFLAGS) -o$(TMPDIR)\$@ $?
-
-$(TMPDIR)\tclWinTest.obj: $(WINDIR)\tclWinTest.c
- $(cc32) $(TCL_CFLAGS) -o$(TMPDIR)\$@ $?
-
-$(TMP_DIR)\tclPkgConfig.obj: $(GENERICDIR)\tclPkgConfig.c
- $(cc32) $(TCL_CFLAGS) \
- -DCFG_INSTALL_EXEC_PREFIX=\"$(INSTALL_EXEC_PREFIX)\" \
- -DCFG_INSTALL_PREFIX=\"$(INSTALL_PREFIX)\" \
- -DCFG_RUNTIME_EXEC_PREFIX=\"$(RUNTIME_EXEC_PREFIX)\" \
- -DCFG_RUNTIME_PREFIX=\"$(RUNTIME_PREFIX)\" \
- -o$(TMPDIR)\$@ $?
-
-$(TMPDIR)\tclAppInit.obj : $(WINDIR)\tclAppInit.c
- $(cc32) $(TCL_CFLAGS) -o$(TMPDIR)\$@ $?
-
-# The following objects should be built using the stub interfaces
-
-# tclWinReg: Produces errors in ANSI mode
-$(TMPDIR)\tclWinReg.obj : $(WINDIR)\tclWinReg.c
- $(cc32) $(TCL_CFLAGS) -DUSE_TCL_STUBS -o$(TMPDIR)\$@ $?
-
-# tclWinDde: Produces errors in ANSI mode
-$(TMPDIR)\tclWinDde.obj : $(WINDIR)\tclWinDde.c
- $(cc32) $(TCL_CFLAGS) -DUSE_TCL_STUBS -o$(TMPDIR)\$@ $?
-
-
-# The following objects are part of the stub library and should not
-# be built as DLL objects but none of the symbols should be exported
-
-$(TMPDIR)\tclStubLib.obj : $(GENERICDIR)\tclStubLib.c
- $(cc32) $(TCL_CFLAGS) -DSTATIC_BUILD -o$(TMPDIR)\$@ $?
-
-
-# Dedependency rules
-
-$(GENERICDIR)\regcomp.c: \
- $(GENERICDIR)\regguts.h \
- $(GENERICDIR)\regc_lex.c \
- $(GENERICDIR)\regc_color.c \
- $(GENERICDIR)\regc_nfa.c \
- $(GENERICDIR)\regc_cvec.c \
- $(GENERICDIR)\regc_locale.c
-
-$(GENERICDIR)\regcustom.h: \
- $(GENERICDIR)\tclInt.h \
- $(GENERICDIR)\tclPort.h \
- $(GENERICDIR)\regex.h
-
-$(GENERICDIR)\regexec.c: \
- $(GENERICDIR)\rege_dfa.c \
- $(GENERICDIR)\regguts.h
-
-$(GENERICDIR)\regerror.c: $(GENERICDIR)\regguts.h
-$(GENERICDIR)\regfree.c: $(GENERICDIR)\regguts.h
-$(GENERICDIR)\regfronts.c: $(GENERICDIR)\regguts.h
-$(GENERICDIR)\regguts.h: $(GENERICDIR)\regcustom.h
-
-#
-# Implicit rules
-#
-
-{$(WINDIR)}.c{$(TMPDIR)}.obj:
- $(cc32) -DBUILD_tcl $(TCL_CFLAGS) -o$@ $<
-
-{$(GENERICDIR)}.c{$(TMPDIR)}.obj:
- $(cc32) -DBUILD_tcl $(TCL_CFLAGS) -o$@ $<
-
-{$(ROOT)\compat}.c{$(TMPDIR)}.obj:
- $(cc32) -DBUILD_tcl $(TCL_CFLAGS) -o$@ $<
-
-{$(WINDIR)}.rc{$(TMPDIR)}.res:
- $(rc32) $(INCLUDEPATH) -D$(USERDEFINES);$(SYSDEFINES) -fo$@ $<
-
-clean:
- -@$(RM) $(OUTDIR)\*.exp
- -@$(RM) $(OUTDIR)\*.lib
- -@$(RM) $(OUTDIR)\*.dll
- -@$(RM) $(OUTDIR)\*.exe
- -@$(RM) $(OUTDIR)\*.pdb
- -@$(RM) $(TMPDIR)\*.pch
- -@$(RM) $(TMPDIR)\*.obj
- -@$(RM) $(TMPDIR)\*.res
- -@$(RM) $(TMPDIR)\*.exe
- -@$(RMDIR) $(OUTDIR)
- -@$(RMDIR) $(TMPDIR)
diff --git a/win/makefile.vc b/win/makefile.vc index cc340a8..0e1e1fd 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -1,7 +1,6 @@ #------------------------------------------------------------- -*- makefile -*-
-# makefile.vc --
#
-# Microsoft Visual C++ makefile for use with nmake.exe v1.62+ (VC++ 5.0+)
+# Microsoft Visual C++ makefile for building Tcl with nmake
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -11,40 +10,18 @@ # Copyright (c) 2001-2005 ActiveState Corporation.
# Copyright (c) 2001-2004 David Gravereaux.
# Copyright (c) 2003-2008 Pat Thoyts.
+# Copyright (c) 2017 Ashok P. Nadkarni
#------------------------------------------------------------------------------
-# Check to see we are configured to build with MSVC (MSDEVDIR, MSVCDIR or
-# VCINSTALLDIR) or with the MS Platform SDK (MSSDK or WindowsSDKDir)
-!if !defined(MSDEVDIR) && !defined(MSVCDIR) && !defined(VCINSTALLDIR) && !defined(MSSDK) && !defined(WINDOWSSDKDIR)
-MSG = ^
-You need to run vcvars32.bat from Developer Studio or setenv.bat from the^
-Platform SDK first to setup the environment. Jump to this line to read^
-the build instructions.
-!error $(MSG)
-!endif
-
-#------------------------------------------------------------------------------
-# HOW TO USE this makefile:
+# General usage:
+# nmake [-nologo] -f makefile.vc [TARGET|MACRODEF [TARGET|MACRODEF] [...]]
#
-# 1) It is now necessary to have MSVCDir, MSDevDir or MSSDK set in the
-# environment. This is used as a check to see if vcvars32.bat had been
-# run prior to running nmake or during the installation of Microsoft
-# Visual C++, MSVCDir had been set globally and the PATH adjusted.
-# Either way is valid.
+# For MACRODEF, see TIP 477 (https://core.tcl.tk/tips/doc/trunk/tip/477.md)
+# or examine Sections 6-8 in rules.vc.
#
-# You'll need to run vcvars32.bat contained in the MsDev's vc(98)/bin
-# directory to setup the proper environment, if needed, for your
-# current setup. This is a needed bootstrap requirement and allows the
-# swapping of different environments to be easier.
-#
-# 2) To use the Platform SDK (not expressly needed), run setenv.bat after
-# vcvars32.bat according to the instructions for it. This can also
-# turn on the 64-bit compiler, if your SDK has it.
-#
-# 3) Targets are:
+# Possible values of TARGET are:
# release -- Builds the core, the shell and the dlls. (default)
-# dlls -- Just builds the windows extensions and the 16-bit DOS
-# pipe/thunk helper app.
+# dlls -- Just builds the windows extensions
# shell -- Just builds the shell and the core.
# core -- Only builds the core [tclXX.(dll|lib)].
# all -- Builds everything.
@@ -62,147 +39,83 @@ the build instructions. # troff manual pages found in $(ROOT)\doc. You need to
# have installed the HTML Help Compiler package from Microsoft
# to produce the .chm file.
-# winhelp -- Builds the windows .hlp file for Tcl from the troff man
-# files found in $(ROOT)\doc.
-#
-# 4) Macros usable on the commandline:
-# INSTALLDIR=<path>
-# Sets where to install Tcl from the built binaries.
-# C:\Progra~1\Tcl is assumed when not specified.
-#
-# OPTS=loimpact,msvcrt,static,staticpkg,symbols,threads,profile,unchecked,none
-# 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.
-#
-# loimpact = Adds a flag for how NT treats the heap to keep memory
-# in use, low. This is said to impact alloc performance.
-# msvcrt = Affects the static option only to switch it from
-# using libcmt(d) as the C runtime [by default] to
-# msvcrt(d). This is useful for static embedding
-# support.
-# static = Builds a static library of the core instead of a
-# dll. The shell will be static (and large), as well.
-# staticpkg= Affects the static option only to switch
-# tclshXX.exe to have the dde and reg extension linked
-# inside it.
-# 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).
-#
-# STATS=compdbg,memdbg,none
-# Sets optional memory and bytecode compiler debugging code added
-# to the core. The default is for none. Any combination of the
-# above may be used (comma separated). 'none' will over-ride
-# everything to nothing.
-#
-# compdbg = Enables byte compilation logging.
-# memdbg = Enables the debugging memory allocator.
-#
-# CHECKS=64bit,fullwarn,nodep,none
-# Sets special macros for checking compatibility.
#
-# 64bit = Enable 64bit portability warnings (if available)
-# fullwarn = Builds with full compiler and link warnings enabled.
-# Very verbose.
-# nodep = Turns off compatibility macros to ensure the core
-# isn't being built with deprecated functions.
+# The steps to setup a Visual C++ environment depend on which
+# version of Visual Studio and/or the Windows SDK you are building
+# against and are not described here. The simplest method is generally
+# to start a command shell using one of the short cuts installed by
+# Visual Studio/Windows SDK for the appropriate target architecture.
#
-# MACHINE=(ALPHA|AMD64|IA64|IX86)
-# Set the machine type used for the compiler, linker, and
-# resource compiler. This hook is needed to tell the tools
-# when alternate platforms are requested. IX86 is the default
-# when not specified. If the CPU environment variable has been
-# set (ie: recent Platform SDK) then MACHINE is set from CPU.
+# NOTE: For older (Visual C++ 6 or the 2003 SDK), to use the Platform
+# SDK (not expressly needed), run setenv.bat after
+# vcvars32.bat according to the instructions for it. This can also
+# turn on the 64-bit compiler, if your SDK has it.
#
-# TMP_DIR=<path>
-# OUT_DIR=<path>
-# Hooks to allow the intermediate and output directories to be
-# changed. $(OUT_DIR) is assumed to be
-# $(BINROOT)\(Release|Debug) based on if symbols are requested.
-# $(TMP_DIR) will de $(OUT_DIR)\<buildtype> by default.
-#
-# TESTPAT=<file>
-# Reads the tests requested to be run from this file.
-#
-# CFG_ENCODING=encoding
-# name of encoding for configuration information. Defaults
-# to cp1252
-#
-# 5) Examples:
-#
-# Basic syntax of calling nmake looks like this:
-# nmake [-nologo] -f makefile.vc [target|macrodef [target|macrodef] [...]]
-#
-# Standard (no frills)
-# c:\tcl_src\win\>c:\progra~1\micros~1\vc98\bin\vcvars32.bat
-# Setting environment for using Microsoft Visual C++ tools.
+# Examples:
# c:\tcl_src\win\>nmake -f makefile.vc release
+# c:\tcl_src\win\>nmake -f makefile.vc test
# c:\tcl_src\win\>nmake -f makefile.vc install INSTALLDIR=c:\progra~1\tcl
+# c:\tcl_src\win\>nmake -f makefile.vc release OPTS=pdbs
+# c:\tcl_src\win\>nmake -f makefile.vc release OPTS=symbols
#
-# Building for Win64
-# c:\tcl_src\win\>c:\progra~1\micros~1\vc98\bin\vcvars32.bat
-# Setting environment for using Microsoft Visual C++ tools.
-# c:\tcl_src\win\>c:\progra~1\platfo~1\setenv.bat /pre64 /RETAIL
-# Targeting Windows pre64 RETAIL
-# c:\tcl_src\win\>nmake -f makefile.vc MACHINE=IA64
-#
-#------------------------------------------------------------------------------
-#==============================================================================
-###############################################################################
+# NOTE:
+# Before modifying this file, check whether the modification is applicable
+# to building extensions as well and if so, modify rules.vc instead.
-# //==================================================================\\
-# >>[ -> Do not modify below this line. <- ]<<
-# >>[ Please, use the commandline macros to modify how Tcl is built. ]<<
-# >>[ If you need more features, send us a patch for more macros. ]<<
-# \\==================================================================//
+# The PROJECT macro is used by rules.vc for generating appropriate
+# macros and rules.
+PROJECT = tcl
+# Default target to build if no target is specified. If unspecified, the
+# rules.vc file will set up "all" as the target.
+DEFAULT_BUILD_TARGET = release
-###############################################################################
-#==============================================================================
-#------------------------------------------------------------------------------
-
-!if !exist("makefile.vc")
-MSG = ^
-You must run this makefile only from the directory it is in.^
-Please `cd` to its location first.
-!error $(MSG)
-!endif
+# We want to use our own resource file, not the standard template one.
+RCFILE = tcl.rc
-PROJECT = tcl
+# The rules.vc file does most of the hard work in terms of defining
+# the build configuration, macros, output directories etc.
!include "rules.vc"
-STUBPREFIX = $(PROJECT)stub
+# Tcl version info based on macros set up by rules.vc
DOTVERSION = $(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION)
VERSION = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION)
+# We need versions of various core packages to generate appropriate
+# file names during installation.
+!if [echo REM = This file is generated from makefile.vc > versions.vc]
+!endif
+!if [echo PKG_HTTP_VER = \>> versions.vc] \
+ && [nmakehlp -V ..\library\http\pkgIndex.tcl http >> versions.vc]
+!endif
+!if [echo PKG_TCLTEST_VER = \>> versions.vc] \
+ && [nmakehlp -V ..\library\tcltest\pkgIndex.tcl tcltest >> versions.vc]
+!endif
+!if [echo PKG_MSGCAT_VER = \>> versions.vc] \
+ && [nmakehlp -V ..\library\msgcat\pkgIndex.tcl msgcat >> versions.vc]
+!endif
+!if [echo PKG_PLATFORM_VER = \>> versions.vc] \
+ && [nmakehlp -V ..\library\platform\pkgIndex.tcl "platform " >> versions.vc]
+!endif
+!if [echo PKG_SHELL_VER = \>> versions.vc] \
+ && [nmakehlp -V ..\library\platform\pkgIndex.tcl "platform::shell" >> versions.vc]
+!endif
+!if [echo PKG_DDE_VER = \>> versions.vc] \
+ && [nmakehlp -V ..\library\dde\pkgIndex.tcl "dde " >> versions.vc]
+!endif
+!if [echo PKG_REG_VER =\>> versions.vc] \
+ && [nmakehlp -V ..\library\reg\pkgIndex.tcl registry >> versions.vc]
+!endif
+
+!include versions.vc
+
DDEDOTVERSION = 1.4
DDEVERSION = $(DDEDOTVERSION:.=)
REGDOTVERSION = 1.3
REGVERSION = $(REGDOTVERSION:.=)
-BINROOT = .
-ROOT = ..
-
-TCLIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib
-TCLLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT)
-TCLLIB = $(OUT_DIR)\$(TCLLIBNAME)
-
-TCLSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib
-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)
@@ -212,28 +125,14 @@ TCLDDELIB = $(OUT_DIR)\$(TCLDDELIBNAME) TCLTEST = $(OUT_DIR)\$(PROJECT)test.exe
CAT32 = $(OUT_DIR)\cat32.exe
-# Can we run what we build? IX86 runs on all architectures.
-!ifndef TCLSH_NATIVE
-!if "$(MACHINE)" == "IX86" || "$(MACHINE)" == "$(NATIVE_ARCH)"
-TCLSH_NATIVE = $(TCLSH)
-!else
-!error You must explicitly set TCLSH_NATIVE for cross-compilation
-!endif
-!endif
-
-### Make sure we use backslash only.
-LIB_INSTALL_DIR = $(_INSTALLDIR)\lib
-BIN_INSTALL_DIR = $(_INSTALLDIR)\bin
-DOC_INSTALL_DIR = $(_INSTALLDIR)\doc
-SCRIPT_INSTALL_DIR = $(_INSTALLDIR)\lib\tcl$(DOTVERSION)
-INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\include
-
TCLSHOBJS = \
$(TMP_DIR)\tclAppInit.obj \
+!if !$(STATIC_BUILD)
!if $(TCL_USE_STATIC_PACKAGES)
$(TMP_DIR)\tclWinReg.obj \
$(TMP_DIR)\tclWinDde.obj \
!endif
+!endif
$(TMP_DIR)\tclsh.res
TCLTESTOBJS = \
@@ -242,18 +141,21 @@ TCLTESTOBJS = \ $(TMP_DIR)\tclTestProcBodyObj.obj \
$(TMP_DIR)\tclThreadTest.obj \
$(TMP_DIR)\tclWinTest.obj \
+!if !$(STATIC_BUILD)
!if $(TCL_USE_STATIC_PACKAGES)
$(TMP_DIR)\tclWinReg.obj \
$(TMP_DIR)\tclWinDde.obj \
!endif
+!endif
$(TMP_DIR)\testMain.obj
-TCLOBJS = \
+COREOBJS = \
$(TMP_DIR)\regcomp.obj \
$(TMP_DIR)\regerror.obj \
$(TMP_DIR)\regexec.obj \
$(TMP_DIR)\regfree.obj \
$(TMP_DIR)\tclAlloc.obj \
+ $(TMP_DIR)\tclAssembly.obj \
$(TMP_DIR)\tclAsync.obj \
$(TMP_DIR)\tclBasic.obj \
$(TMP_DIR)\tclBinary.obj \
@@ -263,12 +165,16 @@ TCLOBJS = \ $(TMP_DIR)\tclCmdIL.obj \
$(TMP_DIR)\tclCmdMZ.obj \
$(TMP_DIR)\tclCompCmds.obj \
+ $(TMP_DIR)\tclCompCmdsGR.obj \
+ $(TMP_DIR)\tclCompCmdsSZ.obj \
$(TMP_DIR)\tclCompExpr.obj \
$(TMP_DIR)\tclCompile.obj \
$(TMP_DIR)\tclConfig.obj \
$(TMP_DIR)\tclDate.obj \
$(TMP_DIR)\tclDictObj.obj \
+ $(TMP_DIR)\tclDisassemble.obj \
$(TMP_DIR)\tclEncoding.obj \
+ $(TMP_DIR)\tclEnsemble.obj \
$(TMP_DIR)\tclEnv.obj \
$(TMP_DIR)\tclEvent.obj \
$(TMP_DIR)\tclExecute.obj \
@@ -285,14 +191,24 @@ TCLOBJS = \ $(TMP_DIR)\tclIOSock.obj \
$(TMP_DIR)\tclIOUtil.obj \
$(TMP_DIR)\tclIORChan.obj \
+ $(TMP_DIR)\tclIORTrans.obj \
$(TMP_DIR)\tclLink.obj \
$(TMP_DIR)\tclListObj.obj \
$(TMP_DIR)\tclLiteral.obj \
$(TMP_DIR)\tclLoad.obj \
$(TMP_DIR)\tclMain.obj \
+ $(TMP_DIR)\tclMain2.obj \
$(TMP_DIR)\tclNamesp.obj \
$(TMP_DIR)\tclNotify.obj \
+ $(TMP_DIR)\tclOO.obj \
+ $(TMP_DIR)\tclOOBasic.obj \
+ $(TMP_DIR)\tclOOCall.obj \
+ $(TMP_DIR)\tclOODefineCmds.obj \
+ $(TMP_DIR)\tclOOInfo.obj \
+ $(TMP_DIR)\tclOOMethod.obj \
+ $(TMP_DIR)\tclOOStubInit.obj \
$(TMP_DIR)\tclObj.obj \
+ $(TMP_DIR)\tclOptimize.obj \
$(TMP_DIR)\tclPanic.obj \
$(TMP_DIR)\tclParse.obj \
$(TMP_DIR)\tclPathObj.obj \
@@ -309,7 +225,6 @@ TCLOBJS = \ $(TMP_DIR)\tclStringObj.obj \
$(TMP_DIR)\tclStrToD.obj \
$(TMP_DIR)\tclStubInit.obj \
- $(TMP_DIR)\tclStubLib.obj \
$(TMP_DIR)\tclThread.obj \
$(TMP_DIR)\tclThreadAlloc.obj \
$(TMP_DIR)\tclThreadJoin.obj \
@@ -320,20 +235,22 @@ TCLOBJS = \ $(TMP_DIR)\tclUtf.obj \
$(TMP_DIR)\tclUtil.obj \
$(TMP_DIR)\tclVar.obj \
- $(TMP_DIR)\tclWin32Dll.obj \
- $(TMP_DIR)\tclWinChan.obj \
- $(TMP_DIR)\tclWinConsole.obj \
- $(TMP_DIR)\tclWinSerial.obj \
- $(TMP_DIR)\tclWinError.obj \
- $(TMP_DIR)\tclWinFCmd.obj \
- $(TMP_DIR)\tclWinFile.obj \
- $(TMP_DIR)\tclWinInit.obj \
- $(TMP_DIR)\tclWinLoad.obj \
- $(TMP_DIR)\tclWinNotify.obj \
- $(TMP_DIR)\tclWinPipe.obj \
- $(TMP_DIR)\tclWinSock.obj \
- $(TMP_DIR)\tclWinThrd.obj \
- $(TMP_DIR)\tclWinTime.obj \
+ $(TMP_DIR)\tclZlib.obj
+
+ZLIBOBJS = \
+ $(TMP_DIR)\adler32.obj \
+ $(TMP_DIR)\compress.obj \
+ $(TMP_DIR)\crc32.obj \
+ $(TMP_DIR)\deflate.obj \
+ $(TMP_DIR)\infback.obj \
+ $(TMP_DIR)\inffast.obj \
+ $(TMP_DIR)\inflate.obj \
+ $(TMP_DIR)\inftrees.obj \
+ $(TMP_DIR)\trees.obj \
+ $(TMP_DIR)\uncompr.obj \
+ $(TMP_DIR)\zutil.obj
+
+TOMMATHOBJS = \
$(TMP_DIR)\bncore.obj \
$(TMP_DIR)\bn_reverse.obj \
$(TMP_DIR)\bn_fast_s_mp_mul_digs.obj \
@@ -397,120 +314,49 @@ TCLOBJS = \ $(TMP_DIR)\bn_s_mp_add.obj \
$(TMP_DIR)\bn_s_mp_mul_digs.obj \
$(TMP_DIR)\bn_s_mp_sqr.obj \
- $(TMP_DIR)\bn_s_mp_sub.obj \
-!if !$(STATIC_BUILD)
- $(TMP_DIR)\tcl.res
-!endif
-
-TCLSTUBOBJS = \
- $(TMP_DIR)\tclStubLib.obj
+ $(TMP_DIR)\bn_s_mp_sub.obj
-### The following paths CANNOT have spaces in them.
-COMPATDIR = $(ROOT)\compat
-DOCDIR = $(ROOT)\doc
-GENERICDIR = $(ROOT)\generic
-TOMMATHDIR = $(ROOT)\libtommath
-TOOLSDIR = $(ROOT)\tools
-WINDIR = $(ROOT)\win
-
-#---------------------------------------------------------------------
-# Compile flags
-#---------------------------------------------------------------------
-
-!if !$(DEBUG)
-!if $(OPTIMIZING)
-### This cranks the optimization level to maximize speed
-cdebug = -O2 $(OPTIMIZATIONS)
-!else
-cdebug =
-!endif
-!if $(SYMBOLS)
-cdebug = $(cdebug) -Zi
-!endif
-!else if "$(MACHINE)" == "IA64" || "$(MACHINE)" == "AMD64"
-### Warnings are too many, can't support warnings into errors.
-cdebug = -Zi -Od $(DEBUGFLAGS)
-!else
-cdebug = -Zi -WX $(DEBUGFLAGS)
-!endif
-
-### Declarations common to all compiler options
-cwarn = $(WARNINGS) -D _CRT_SECURE_NO_DEPRECATE -D _CRT_NONSTDC_NO_DEPRECATE
-cflags = -nologo -c $(COMPILERFLAGS) $(cwarn) -Fp$(TMP_DIR)^\
-
-!if $(MSVCRT)
-!if $(DEBUG) && !$(UNCHECKED)
-crt = -MDd
-!else
-crt = -MD
-!endif
-!else
-!if $(DEBUG) && !$(UNCHECKED)
-crt = -MTd
-!else
-crt = -MT
-!endif
-!endif
-
-TCL_INCLUDES = -I"$(WINDIR)" -I"$(GENERICDIR)" -I"$(TOMMATHDIR)"
-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)
-STUB_CFLAGS = $(cflags) $(cdebug) $(OPTDEFINES)
-
-
-#---------------------------------------------------------------------
-# Link flags
-#---------------------------------------------------------------------
-
-!if $(DEBUG)
-ldebug = -debug -debugtype:cv
+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
-ldebug = -release -opt:ref -opt:icf,3
-!if $(SYMBOLS)
-ldebug = $(ldebug) -debug -debugtype:cv
-!endif
-!endif
-
-### Declarations common to all linker options
-lflags = -nologo -machine:$(MACHINE) $(LINKERFLAGS) $(ldebug)
-
-!if $(PROFILE)
-lflags = $(lflags) -profile
+ $(TMP_DIR)\tcl.res
!endif
-!if $(MSVCRT) && !($(DEBUG) && !$(UNCHECKED)) && $(VCVERSION) >= 1900
-lflags = $(lflags) -nodefaultlib:libucrt.lib
-!endif
+TCLOBJS = $(COREOBJS) $(ZLIBOBJS) $(TOMMATHOBJS) $(PLATFORMOBJS)
-!if $(ALIGN98_HACK) && !$(STATIC_BUILD)
-### Align sections for PE size savings.
-lflags = $(lflags) -opt:nowin98
-!else if !$(ALIGN98_HACK) && $(STATIC_BUILD)
-### Align sections for speed in loading by choosing the virtual page size.
-lflags = $(lflags) -align:4096
-!endif
+TCLSTUBOBJS = \
+ $(TMP_DIR)\tclStubLib.obj \
+ $(TMP_DIR)\tclTomMathStubLib.obj \
+ $(TMP_DIR)\tclOOStubLib.obj
-!if $(LOIMPACT)
-lflags = $(lflags) -ws:aggressive
-!endif
+### The following paths CANNOT have spaces in them as they appear on
+### the left side of implicit rules.
+TOMMATHDIR = $(ROOT)\libtommath
+PKGSDIR = $(ROOT)\pkgs
-dlllflags = $(lflags) -dll
-conlflags = $(lflags) -subsystem:console
-guilflags = $(lflags) -subsystem:windows
+# Additional include and C macro definitions for the implicit rules
+# defined in rules.vc
+PRJ_INCLUDES = -I"$(TOMMATHDIR)"
+PRJ_DEFINES = -DTCL_TOMMATH -DMP_PREC=4 -Dinline=__inline -DHAVE_ZLIB=1 -D_CRT_SECURE_NO_DEPRECATE -D_CRT_NONSTDC_NO_DEPRECATE
-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"
-!if $(VCVERSION) > 1399 && $(VCVERSION) < 1500
-baselibs = $(baselibs) bufferoverflowU.lib
-!endif
-!endif
-!if $(MSVCRT) && !($(DEBUG) && !$(UNCHECKED)) && $(VCVERSION) >= 1900
-baselibs = $(baselibs) ucrt.lib
-!endif
+# Additional Link libraries needed beyond those in rules.vc
+PRJ_LIBS = netapi32.lib user32.lib userenv.lib ws2_32.lib
#---------------------------------------------------------------------
# TclTest flags
@@ -525,30 +371,22 @@ TESTFLAGS = $(TESTFLAGS) -file $(TESTPAT) # Project specific targets
#---------------------------------------------------------------------
-release: setup $(TCLSH) $(TCLSTUBLIB) dlls
+release: setup $(TCLSH) $(TCLSTUBLIB) dlls pkgs
core: setup $(TCLLIB) $(TCLSTUBLIB)
shell: setup $(TCLSH)
-dlls: setup $(TCLPIPEDLL) $(TCLREGLIB) $(TCLDDELIB)
-all: setup $(TCLSH) $(TCLSTUBLIB) dlls $(CAT32)
+dlls: setup $(TCLREGLIB) $(TCLDDELIB)
+all: setup $(TCLSH) $(TCLSTUBLIB) dlls $(CAT32) pkgs
tcltest: setup $(TCLTEST) dlls $(CAT32)
-install: install-binaries install-libraries install-docs
+install: install-binaries install-libraries install-docs install-pkgs
+setup: default-setup
-test: test-core
+test: test-core test-pkgs
test-core: setup $(TCLTEST) dlls $(CAT32)
set TCL_LIBRARY=$(ROOT:\=/)/library
-!if "$(OS)" == "Windows_NT" || "$(MSVCDIR)" == "IDE"
$(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile <<
package ifneeded dde 1.4.1 [list load "$(TCLDDELIB:\=/)" dde]
package ifneeded registry 1.3.3 [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.1 "$(TCLDDELIB:\=/)" dde]
- package ifneeded registry 1.3.3 "$(TCLREGLIB:\=/)" registry]
-<<
- type tests.log | more
-!endif
runtest: setup $(TCLTEST) dlls $(CAT32)
set TCL_LIBRARY=$(ROOT:\=/)/library
@@ -558,72 +396,89 @@ runshell: setup $(TCLSH) dlls set TCL_LIBRARY=$(ROOT:\=/)/library
$(DEBUGGER) $(TCLSH) $(SCRIPT)
-setup:
- @if not exist $(OUT_DIR)\nul mkdir $(OUT_DIR)
- @if not exist $(TMP_DIR)\nul mkdir $(TMP_DIR)
-
-!if !$(STATIC_BUILD)
-$(TCLIMPLIB): $(TCLLIB)
-!endif
+!if $(STATIC_BUILD)
$(TCLLIB): $(TCLOBJS)
-!if $(STATIC_BUILD)
- $(lib32) -nologo $(LINKERFLAGS) -out:$@ @<<
+ $(LIBCMD) @<<
$**
<<
+
!else
- $(link32) $(dlllflags) -base:@$(WINDIR)\coffbase.txt,tcl -out:$@ \
- $(baselibs) @<<
+
+$(TCLLIB): $(TCLOBJS)
+ $(DLLCMD) @<<
$**
<<
$(_VC_MANIFEST_EMBED_DLL)
- -@del $*.exp
-!endif
+$(TCLIMPLIB): $(TCLLIB)
+
+!endif # $(STATIC_BUILD)
+
$(TCLSTUBLIB): $(TCLSTUBOBJS)
- $(lib32) -nologo $(LINKERFLAGS) -nodefaultlib -out:$@ $(TCLSTUBOBJS)
+ $(LIBCMD) -nodefaultlib $(TCLSTUBOBJS)
$(TCLSH): $(TCLSHOBJS) $(TCLSTUBLIB) $(TCLIMPLIB)
- $(link32) $(conlflags) -stack:2300000 -out:$@ $(baselibs) $**
+ $(CONEXECMD) -stack:2300000 $**
$(_VC_MANIFEST_EMBED_EXE)
$(TCLTEST): $(TCLTESTOBJS) $(TCLSTUBLIB) $(TCLIMPLIB)
- $(link32) $(conlflags) -stack:2300000 -out:$@ $(baselibs) $**
+ $(CONEXECMD) -stack:2300000 $**
$(_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:$@ $**
+ $(LIBCMD) $**
!else
$(TCLDDELIB): $(TMP_DIR)\tclWinDde.obj $(TCLSTUBLIB)
- $(link32) $(dlllflags) -base:@$(WINDIR)\coffbase.txt,tcldde -out:$@ \
- $** $(baselibs)
+ $(DLLCMD) $**
$(_VC_MANIFEST_EMBED_DLL)
- -@del $*.exp
- -@del $*.lib
!endif
!if $(STATIC_BUILD)
$(TCLREGLIB): $(TMP_DIR)\tclWinReg.obj
- $(lib32) -nologo $(LINKERFLAGS) -out:$@ $**
+ $(LIBCMD) $**
!else
$(TCLREGLIB): $(TMP_DIR)\tclWinReg.obj $(TCLSTUBLIB)
- $(link32) $(dlllflags) -base:@$(WINDIR)\coffbase.txt,tclreg -out:$@ \
- $** $(baselibs)
+ $(DLLCMD) $**
$(_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 \
- $(baselibs)
+ $(cc32) $(cflags) $(crt) -D_CRT_NONSTDC_NO_DEPRECATE -DCONSOLE -Fo$(TMP_DIR)\ $?
+ $(CONEXECMD) -stack:16384 $(TMP_DIR)\cat.obj
$(_VC_MANIFEST_EMBED_EXE)
#---------------------------------------------------------------------
@@ -637,6 +492,8 @@ genstubs: $(TCLSH) $(TOOLSDIR:\=/)/genStubs.tcl $(GENERICDIR:\=/) \
$(GENERICDIR:\=/)/tcl.decls $(GENERICDIR:\=/)/tclInt.decls \
$(GENERICDIR:\=/)/tclTomMath.decls
+ $(TCLSH) $(TOOLSDIR:\=/)/genStubs.tcl $(GENERICDIR:\=/) \
+ $(GENERICDIR:\=/)/tclOO.decls
!endif
@@ -659,11 +516,14 @@ gentommath_h: # Build the Windows HTML help file.
#---------------------------------------------------------------------
-# NOTE: you can define HHC on the command-line to override this
-!ifndef HHC
-HHC=""%ProgramFiles%\HTML Help Workshop\hhc.exe""
+# NOTE: you can define HHC on the command-line to override this.
+# nmake does not set macro values if already set on the command line.
+!if defined(PROCESSOR_ARCHITECTURE) && "$(PROCESSOR_ARCHITECTURE)" == "AMD64"
+HHC="%ProgramFiles(x86)%\HTML Help Workshop\hhc.exe"
+!else
+HHC="%ProgramFiles%\HTML Help Workshop\hhc.exe"
!endif
-HTMLDIR=$(ROOT)\html
+HTMLDIR=$(OUT_DIR)\html
HTMLBASE=TclTk$(VERSION)
HHPFILE=$(HTMLDIR)\$(HTMLBASE).hhp
CHMFILE=$(HTMLDIR)\$(HTMLBASE).chm
@@ -671,100 +531,53 @@ CHMFILE=$(HTMLDIR)\$(HTMLBASE).chm htmlhelp: chmsetup $(CHMFILE)
$(CHMFILE): $(DOCDIR)\*
- @$(TCLSH) $(TOOLSDIR)\tcltk-man2html.tcl
+ @$(TCLSH) $(TOOLSDIR)\tcltk-man2html.tcl "--htmldir=$(HTMLDIR)"
@echo Compiling HTML help project
- @$(HHC) <<$(HHPFILE) >NUL
+ -"$(HHC)" <<$(HHPFILE) >NUL
[OPTIONS]
Compatibility=1.1 or later
Compiled file=$(HTMLBASE).chm
+Default topic=contents.htm
Display compile progress=no
Error log file=$(HTMLBASE).log
+Full-text search=Yes
Language=0x409 English (United States)
-Title=Tcl/Tk $(DOT_VERSION) Help
+Title=Tcl/Tk $(DOTVERSION) Help
[FILES]
contents.htm
docs.css
-Keywords
-TclCmd
-TclLib
-TkCmd
-TkLib
-UserCmd
+Keywords\*.htm
+TclCmd\*.htm
+TclLib\*.htm
+TkCmd\*.htm
+TkLib\*.htm
+UserCmd\*.htm
<<
chmsetup:
@if not exist $(HTMLDIR)\nul mkdir $(HTMLDIR)
-#-------------------------------------------------------------------------
-# Build the old-style Windows .hlp file
-#-------------------------------------------------------------------------
-
-TCLHLPBASE = $(PROJECT)$(VERSION)
-HELPFILE = $(OUT_DIR)\$(TCLHLPBASE).hlp
-HELPCNT = $(OUT_DIR)\$(TCLHLPBASE).cnt
-DOCTMP_DIR = $(OUT_DIR)\$(PROJECT)_docs
-HELPRTF = $(DOCTMP_DIR)\$(PROJECT).rtf
-MAN2HELP = $(DOCTMP_DIR)\man2help.tcl
-MAN2HELP2 = $(DOCTMP_DIR)\man2help2.tcl
-INDEX = $(DOCTMP_DIR)\index.tcl
-BMP = $(DOCTMP_DIR)\feather.bmp
-BMP_NOPATH = feather.bmp
-MAN2TCL = $(DOCTMP_DIR)\man2tcl.exe
-
-winhelp: docsetup $(HELPFILE)
-
-docsetup:
- @if not exist $(DOCTMP_DIR)\nul mkdir $(DOCTMP_DIR)
-
-$(MAN2HELP) $(MAN2HELP2) $(INDEX) $(BMP): $(TOOLSDIR)\$$(@F)
- @$(CPY) $(TOOLSDIR)\$(@F) $(@D)
-
-$(HELPFILE): $(HELPRTF) $(BMP)
- cd $(DOCTMP_DIR)
- start /wait hcrtf.exe -x <<$(PROJECT).hpj
-[OPTIONS]
-COMPRESS=12 Hall Zeck
-LCID=0x409 0x0 0x0 ; English (United States)
-TITLE=Tcl/Tk Reference Manual
-BMROOT=.
-CNT=$(@B).cnt
-HLP=$(@B).hlp
-
-[FILES]
-$(PROJECT).rtf
-
-[WINDOWS]
-main="Tcl/Tk Reference Manual",,27648,(r15263976),(r65535)
-
-[CONFIG]
-BrowseButtons()
-CreateButton(1, "Web", ExecFile("http://www.tcl.tk"))
-CreateButton(2, "SF", ExecFile("http://sf.net/projects/tcl"))
-CreateButton(3, "Wiki", ExecFile("http://wiki.tcl.tk"))
-CreateButton(4, "FAQ", ExecFile("http://www.purl.org/NET/Tcl-FAQ/"))
-<<
- cd $(MAKEDIR)
- @$(CPY) "$(DOCTMP_DIR)\$(@B).hlp" "$(OUT_DIR)"
- @$(CPY) "$(DOCTMP_DIR)\$(@B).cnt" "$(OUT_DIR)"
-
-$(MAN2TCL): $(TOOLSDIR)\$$(@B).c
- $(cc32) $(TCL_CFLAGS) -Fo$(@D)\ $(TOOLSDIR)\$(@B).c
- $(link32) $(conlflags) -out:$@ -stack:16384 $(@D)\man2tcl.obj
- $(_VC_MANIFEST_EMBED_EXE)
-
-$(HELPRTF): $(MAN2TCL) $(MAN2HELP) $(MAN2HELP2) $(INDEX) $(DOCDIR)\*
- $(TCLSH) $(MAN2HELP) -bitmap $(BMP_NOPATH) $(PROJECT) $(VERSION) $(DOCDIR:\=/)
-
install-docs:
!if exist("$(CHMFILE)")
@echo Installing compiled HTML help
@$(CPY) "$(CHMFILE)" "$(DOC_INSTALL_DIR)\"
!endif
-!if exist("$(HELPFILE)")
- @echo Installing Windows help
- @$(CPY) "$(HELPFILE)" "$(DOC_INSTALL_DIR)\"
- @$(CPY) "$(HELPCNT)" "$(DOC_INSTALL_DIR)\"
-!endif
+
+# "emacs font-lock highlighting fix
+
+#---------------------------------------------------------------------
+# Generate the tcl.nmake file which contains the options used to build
+# Tcl itself. This is used when building extensions.
+#---------------------------------------------------------------------
+tcl-nmake: $(OUT_DIR)\tcl.nmake
+$(OUT_DIR)\tcl.nmake:
+ @type << >$@
+CORE_MACHINE = $(MACHINE)
+CORE_DEBUG = $(DEBUG)
+CORE_TCL_THREADS = $(TCL_THREADS)
+CORE_USE_THREAD_ALLOC = $(USE_THREAD_ALLOC)
+CORE_USE_WIDECHAR_API = $(USE_WIDECHAR_API)
+<<
#---------------------------------------------------------------------
# Build tclConfig.sh for the TEA build system.
@@ -772,6 +585,7 @@ install-docs: tclConfig: $(OUT_DIR)\tclConfig.sh
+# TBD - is this tclConfig.sh file ever used? The values are incorrect!
$(OUT_DIR)\tclConfig.sh: $(WINDIR)\tclConfig.sh.in
@echo Creating tclConfig.sh
@nmakehlp -s << $** >$@
@@ -781,7 +595,7 @@ $(OUT_DIR)\tclConfig.sh: $(WINDIR)\tclConfig.sh.in @TCL_MINOR_VERSION@ $(TCL_MINOR_VERSION)
@TCL_PATCH_LEVEL@ $(TCL_PATCH_LEVEL)
@CC@ $(CC)
-@DEFS@ $(TCL_CFLAGS)
+@DEFS@ $(pkgcflags)
@CFLAGS_DEBUG@ -nologo -c -W3 -YX -Fp$(TMP_DIR)\ -MDd
@CFLAGS_OPTIMIZE@ -nologo -c -W3 -YX -Fp$(TMP_DIR)\ -MD
@LDFLAGS_DEBUG@ -nologo -machine:$(MACHINE) -debug -debugtype:cv
@@ -789,7 +603,7 @@ $(OUT_DIR)\tclConfig.sh: $(WINDIR)\tclConfig.sh.in @TCL_DBGX@ $(SUFX)
@TCL_LIB_FILE@ $(PROJECT)$(VERSION)$(SUFX).lib
@TCL_NEEDS_EXP_FILE@
-@LIBS@ $(baselibs)
+@LIBS@ $(baselibs) $(PRJ_LIBS)
@prefix@ $(_INSTALLDIR)
@exec_prefix@ $(BIN_INSTALL_DIR)
@SHLIB_CFLAGS@
@@ -798,10 +612,11 @@ $(OUT_DIR)\tclConfig.sh: $(WINDIR)\tclConfig.sh.in @EXTRA_CFLAGS@ -YX
@SHLIB_LD@ $(link32) $(dlllflags)
@STLIB_LD@ $(lib32) -nologo
-@SHLIB_LD_LIBS@ $(baselibs)
+@SHLIB_LD_LIBS@ $(baselibs) $(PRJ_LIBS)
@SHLIB_SUFFIX@ .dll
@DL_LIBS@
@LDFLAGS@
+@TCL_CC_SEARCH_FLAGS@
@TCL_LD_SEARCH_FLAGS@
@LIBOBJS@
@RANLIB@
@@ -848,21 +663,28 @@ gendate: #---------------------------------------------------------------------
$(TMP_DIR)\testMain.obj: $(WINDIR)\tclAppInit.c
- $(cc32) $(TCL_CFLAGS) -DTCL_TEST \
+ $(cc32) $(appcflags) -DTCL_TEST \
-DTCL_USE_STATIC_PACKAGES=$(TCL_USE_STATIC_PACKAGES) \
-Fo$@ $?
+$(TMP_DIR)\tclMain2.obj: $(GENERICDIR)\tclMain.c
+ $(cc32) $(pkgcflags) -DTCL_ASCII_MAIN \
+ -Fo$@ $?
+
$(TMP_DIR)\tclTest.obj: $(GENERICDIR)\tclTest.c
- $(cc32) $(TCL_CFLAGS) -Fo$@ $?
+ $(cc32) $(appcflags) -Fo$@ $?
$(TMP_DIR)\tclTestObj.obj: $(GENERICDIR)\tclTestObj.c
- $(cc32) $(TCL_CFLAGS) -Fo$@ $?
+ $(cc32) $(appcflags) -Fo$@ $?
$(TMP_DIR)\tclWinTest.obj: $(WINDIR)\tclWinTest.c
- $(cc32) $(TCL_CFLAGS) -Fo$@ $?
+ $(CCAPPCMD) $?
+
+$(TMP_DIR)\tclZlib.obj: $(GENERICDIR)\tclZlib.c
+ $(cc32) $(pkgcflags) -I$(COMPATDIR)\zlib -Fo$@ $?
$(TMP_DIR)\tclPkgConfig.obj: $(GENERICDIR)\tclPkgConfig.c
- $(cc32) -DBUILD_tcl $(TCL_CFLAGS) \
+ $(cc32) $(pkgcflags) \
-DCFG_INSTALL_LIBDIR="\"$(LIB_INSTALL_DIR:\=\\)\"" \
-DCFG_INSTALL_BINDIR="\"$(BIN_INSTALL_DIR:\=\\)\"" \
-DCFG_INSTALL_SCRDIR="\"$(SCRIPT_INSTALL_DIR:\=\\)\"" \
@@ -876,7 +698,7 @@ $(TMP_DIR)\tclPkgConfig.obj: $(GENERICDIR)\tclPkgConfig.c -Fo$@ $?
$(TMP_DIR)\tclAppInit.obj: $(WINDIR)\tclAppInit.c
- $(cc32) $(TCL_CFLAGS) \
+ $(cc32) $(appcflags) \
-DTCL_USE_STATIC_PACKAGES=$(TCL_USE_STATIC_PACKAGES) \
-Fo$@ $?
@@ -885,17 +707,17 @@ $(TMP_DIR)\tclAppInit.obj: $(WINDIR)\tclAppInit.c $(TMP_DIR)\tclWinReg.obj: $(WINDIR)\tclWinReg.c
!if $(STATIC_BUILD)
- $(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DSTATIC_BUILD -DUNICODE -D_UNICODE -Fo$@ $?
+ $(cc32) $(appcflags) -DSTATIC_BUILD -Fo$@ $?
!else
- $(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DUSE_TCL_STUBS -DUNICODE -D_UNICODE -Fo$@ $?
+ $(cc32) $(appcflags) -DUSE_TCL_STUBS -Fo$@ $?
!endif
$(TMP_DIR)\tclWinDde.obj: $(WINDIR)\tclWinDde.c
!if $(STATIC_BUILD)
- $(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DSTATIC_BUILD -DUNICODE -D_UNICODE -Fo$@ $?
+ $(cc32) $(appcflags) -DSTATIC_BUILD -Fo$@ $?
!else
- $(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DUSE_TCL_STUBS -DUNICODE -D_UNICODE -Fo$@ $?
+ $(cc32) $(appcflags) -DUSE_TCL_STUBS -Fo$@ $?
!endif
@@ -904,7 +726,13 @@ $(TMP_DIR)\tclWinDde.obj: $(WINDIR)\tclWinDde.c ### specific C run-time.
$(TMP_DIR)\tclStubLib.obj: $(GENERICDIR)\tclStubLib.c
- $(cc32) $(STUB_CFLAGS) -Zl -DSTATIC_BUILD $(TCL_INCLUDES) -Fo$@ $?
+ $(cc32) $(stubscflags) -Fo$@ $?
+
+$(TMP_DIR)\tclTomMathStubLib.obj: $(GENERICDIR)\tclTomMathStubLib.c
+ $(cc32) $(stubscflags) -Fo$@ $?
+
+$(TMP_DIR)\tclOOStubLib.obj: $(GENERICDIR)\tclOOStubLib.c
+ $(cc32) $(stubscflags) -Fo$@ $?
$(TMP_DIR)\tclsh.exe.manifest: $(WINDIR)\tclsh.exe.manifest.in
@nmakehlp -s << $** >$@
@@ -925,7 +753,7 @@ depend: @echo Build tclsh first!
!else
$(TCLSH) $(TOOLSDIR:\=/)/mkdepend.tcl -vc32 -out:"$(OUT_DIR)\depend.mk" \
- -passthru:"-DBUILD_tcl $(TCL_INCLUDES)" $(GENERICDIR),$$(GENERICDIR) \
+ -passthru:"-DBUILD_tcl $(TCL_INCLUDES) $(PRJ_INCLUDES)" $(GENERICDIR),$$(GENERICDIR) \
$(COMPATDIR),$$(COMPATDIR) $(TOMMATHDIR),$$(TOMMATHDIR) $(WINDIR),$$(WINDIR) @<<
$(TCLOBJS)
<<
@@ -947,40 +775,23 @@ $(TCLOBJS) #---------------------------------------------------------------------
-# Implicit rules
+# Implicit rules that are not covered by the common ones defined in
+# rules.vc. A limitation exists with nmake that requires that
+# source directory can not contain spaces in the path. This an
+# absolute.
#---------------------------------------------------------------------
-{$(WINDIR)}.c{$(TMP_DIR)}.obj::
- $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<<
-$<
-<<
-
{$(TOMMATHDIR)}.c{$(TMP_DIR)}.obj::
- $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<<
+ $(cc32) $(pkgcflags) -Fo$(TMP_DIR)\ @<<
$<
<<
-{$(GENERICDIR)}.c{$(TMP_DIR)}.obj::
- $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<<
+{$(COMPATDIR)\zlib}.c{$(TMP_DIR)}.obj::
+ $(cc32) $(pkgcflags) -Fo$(TMP_DIR)\ @<<
$<
<<
-{$(COMPATDIR)}.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) \
- -d TCL_THREADS=$(TCL_THREADS) \
- -d STATIC_BUILD=$(STATIC_BUILD) \
- $<
-
-$(TMP_DIR)\tclsh.res: $(TMP_DIR)\tclsh.exe.manifest
-
-.SUFFIXES:
-.SUFFIXES:.c .rc
+$(TMP_DIR)\tclsh.res: $(TMP_DIR)\tclsh.exe.manifest $(WINDIR)\tclsh.rc
#---------------------------------------------------------------------
@@ -998,29 +809,29 @@ 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)\"
-#" emacs fix
-
-install-libraries: tclConfig install-msgs install-tzdata
- @if not exist "$(SCRIPT_INSTALL_DIR)$(NULL)" \
+install-libraries: tclConfig tcl-nmake install-msgs install-tzdata
+ @if not exist "$(SCRIPT_INSTALL_DIR)" \
$(MKDIR) "$(SCRIPT_INSTALL_DIR)"
- @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl8$(NULL)" \
+ @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl8" \
$(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl8"
- @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4$(NULL)" \
+ @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4" \
$(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4"
- @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4\platform$(NULL)" \
+ @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4\platform" \
$(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4\platform"
- @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.5$(NULL)" \
+ @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.5" \
$(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.5"
+ @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.6" \
+ $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.6"
+ @if not exist "$(LIB_INSTALL_DIR)\nmake" \
+ $(MKDIR) "$(LIB_INSTALL_DIR)\nmake"
@echo Installing header files
@$(CPY) "$(GENERICDIR)\tcl.h" "$(INCLUDE_INSTALL_DIR)\"
@$(CPY) "$(GENERICDIR)\tclDecls.h" "$(INCLUDE_INSTALL_DIR)\"
+ @$(CPY) "$(GENERICDIR)\tclOO.h" "$(INCLUDE_INSTALL_DIR)\"
+ @$(CPY) "$(GENERICDIR)\tclOODecls.h" "$(INCLUDE_INSTALL_DIR)\"
@$(CPY) "$(GENERICDIR)\tclPlatDecls.h" "$(INCLUDE_INSTALL_DIR)\"
@$(CPY) "$(GENERICDIR)\tclTomMath.h" "$(INCLUDE_INSTALL_DIR)\"
@$(CPY) "$(GENERICDIR)\tclTomMathDecls.h" "$(INCLUDE_INSTALL_DIR)\"
@@ -1038,6 +849,11 @@ 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)\"
+ @$(CPY) "$(WINDIR)\rules.vc" "$(LIB_INSTALL_DIR)\nmake\"
+ @$(CPY) "$(WINDIR)\targets.vc" "$(LIB_INSTALL_DIR)\nmake\"
+ @$(CPY) "$(WINDIR)\nmakehlp.c" "$(LIB_INSTALL_DIR)\nmake\"
+ @$(CPY) "$(OUT_DIR)\tcl.nmake" "$(LIB_INSTALL_DIR)\nmake\"
@echo Installing library http1.0 directory
@$(CPY) "$(ROOT)\library\http1.0\*.tcl" \
"$(SCRIPT_INSTALL_DIR)\http1.0\"
@@ -1046,7 +862,7 @@ install-libraries: tclConfig install-msgs install-tzdata "$(SCRIPT_INSTALL_DIR)\opt0.4\"
@echo Installing package http $(PKG_HTTP_VER) as a Tcl Module
@$(COPY) "$(ROOT)\library\http\http.tcl" \
- "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4\http-$(PKG_HTTP_VER).tm"
+ "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.6\http-$(PKG_HTTP_VER).tm"
@echo Installing package msgcat $(PKG_MSGCAT_VER) as a Tcl Module
@$(COPY) "$(ROOT)\library\msgcat\msgcat.tcl" \
"$(SCRIPT_INSTALL_DIR)\..\tcl8\8.5\msgcat-$(PKG_MSGCAT_VER).tm"
@@ -1082,8 +898,7 @@ install-libraries: tclConfig install-msgs install-tzdata @echo Installing encodings
@$(CPY) "$(ROOT)\library\encoding\*.enc" \
"$(SCRIPT_INSTALL_DIR)\encoding\"
-
-#" emacs fix
+# "emacs font-lock highlighting fix
install-tzdata:
@echo Installing time zone data
@@ -1117,24 +932,10 @@ tidy: @echo Removing $(TCLREGLIB) ...
@if exist $(TCLREGLIB) del $(TCLREGLIB)
-clean:
- @echo Cleaning $(TMP_DIR)\* ...
- @if exist $(TMP_DIR)\nul $(RMDIR) $(TMP_DIR)
- @echo Cleaning $(WINDIR)\nmakehlp.obj ...
- @if exist $(WINDIR)\nmakehlp.obj del $(WINDIR)\nmakehlp.obj
- @echo Cleaning $(WINDIR)\nmakehlp.exe ...
- @if exist $(WINDIR)\nmakehlp.exe del $(WINDIR)\nmakehlp.exe
- @echo Cleaning $(WINDIR)\_junk.pch ...
- @if exist $(WINDIR)\_junk.pch del $(WINDIR)\_junk.pch
- @echo Cleaning $(WINDIR)\vercl.x ...
- @if exist $(WINDIR)\vercl.x del $(WINDIR)\vercl.x
- @echo Cleaning $(WINDIR)\vercl.i ...
- @if exist $(WINDIR)\vercl.i del $(WINDIR)\vercl.i
- @echo Cleaning $(WINDIR)\versions.vc ...
- @if exist $(WINDIR)\versions.vc del $(WINDIR)\versions.vc
-
+clean: default-clean clean-pkgs
+hose: default-hose
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 0439d1c..b759020 100644 --- a/win/nmakehlp.c +++ b/win/nmakehlp.c @@ -14,13 +14,8 @@ #define _CRT_SECURE_NO_DEPRECATE #include <windows.h> -#define NO_SHLWAPI_GDI -#define NO_SHLWAPI_STREAM -#define NO_SHLWAPI_REG -#include <shlwapi.h> #pragma comment (lib, "user32.lib") #pragma comment (lib, "kernel32.lib") -#pragma comment (lib, "shlwapi.lib") #include <stdio.h> #include <math.h> @@ -39,7 +34,6 @@ #endif - /* protos */ static int CheckForCompilerFeature(const char *option); @@ -47,6 +41,7 @@ static int CheckForLinkerFeature(const char **options, int count); static int IsIn(const char *string, const char *substring); static int SubstituteFile(const char *substs, const char *filename); static int QualifyPath(const char *path); +static int LocateDependency(const char *keyfile); static const char *GetVersionFromFile(const char *filename, const char *match, int numdots); static DWORD WINAPI ReadFromPipe(LPVOID args); @@ -74,7 +69,7 @@ main( char msg[300]; DWORD dwWritten; int chars; - char *s; + const char *s; /* * Make sure children (cl.exe and link.exe) are kept quiet. @@ -172,6 +167,18 @@ main( return 2; } return QualifyPath(argv[2]); + + case 'L': + if (argc != 3) { + chars = snprintf(msg, sizeof(msg) - 1, + "usage: %s -L keypath\n" + "Emit the fully qualified path of directory containing keypath\n" + "exitcodes: 0 == success, 1 == not found, 2 == error\n", argv[0]); + WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, + &dwWritten, NULL); + return 2; + } + return LocateDependency(argv[2]); } } chars = snprintf(msg, sizeof(msg) - 1, @@ -676,6 +683,17 @@ SubstituteFile( return 0; } +BOOL FileExists(LPCTSTR szPath) +{ +#ifndef INVALID_FILE_ATTRIBUTES + #define INVALID_FILE_ATTRIBUTES ((DWORD)-1) +#endif + DWORD pathAttr = GetFileAttributes(szPath); + return (pathAttr != INVALID_FILE_ATTRIBUTES && + !(pathAttr & FILE_ATTRIBUTE_DIRECTORY)); +} + + /* * QualifyPath -- * @@ -689,18 +707,104 @@ QualifyPath( const char *szPath) { char szCwd[MAX_PATH + 1]; - char szTmp[MAX_PATH + 1]; - char *p; - GetCurrentDirectory(MAX_PATH, szCwd); - while ((p = strchr(szPath, '/')) && *p) - *p = '\\'; - PathCombine(szTmp, szCwd, szPath); - PathCanonicalize(szCwd, szTmp); + + GetFullPathName(szPath, sizeof(szCwd)-1, szCwd, NULL); printf("%s\n", szCwd); return 0; } /* + * Implements LocateDependency for a single directory. See that command + * for an explanation. + * Returns 0 if found after printing the directory. + * Returns 1 if not found but no errors. + * Returns 2 on any kind of error + * Basically, these are used as exit codes for the process. + */ +static int LocateDependencyHelper(const char *dir, const char *keypath) +{ + HANDLE hSearch; + char path[MAX_PATH+1]; + int dirlen, keylen, ret; + WIN32_FIND_DATA finfo; + + if (dir == NULL || keypath == NULL) + return 2; /* Have no real error reporting mechanism into nmake */ + dirlen = strlen(dir); + if ((dirlen + 3) > sizeof(path)) + return 2; + strncpy(path, dir, dirlen); + strncpy(path+dirlen, "\\*", 3); /* Including terminating \0 */ + keylen = strlen(keypath); + +#if 0 /* This function is not available in Visual C++ 6 */ + /* + * Use numerics 0 -> FindExInfoStandard, + * 1 -> FindExSearchLimitToDirectories, + * as these are not defined in Visual C++ 6 + */ + hSearch = FindFirstFileEx(path, 0, &finfo, 1, NULL, 0); +#else + hSearch = FindFirstFile(path, &finfo); +#endif + if (hSearch == INVALID_HANDLE_VALUE) + return 1; /* Not found */ + + /* Loop through all subdirs checking if the keypath is under there */ + ret = 1; /* Assume not found */ + do { + int sublen; + /* + * We need to check it is a directory despite the + * FindExSearchLimitToDirectories in the above call. See SDK docs + */ + if ((finfo.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) == 0) + continue; + sublen = strlen(finfo.cFileName); + if ((dirlen+1+sublen+1+keylen+1) > sizeof(path)) + continue; /* Path does not fit, assume not matched */ + strncpy(path+dirlen+1, finfo.cFileName, sublen); + path[dirlen+1+sublen] = '\\'; + strncpy(path+dirlen+1+sublen+1, keypath, keylen+1); + if (FileExists(path)) { + /* Found a match, print to stdout */ + path[dirlen+1+sublen] = '\0'; + QualifyPath(path); + ret = 0; + break; + } + } while (FindNextFile(hSearch, &finfo)); + FindClose(hSearch); + return ret; +} + +/* + * LocateDependency -- + * + * Locates a dependency for a package. + * keypath - a relative path within the package directory + * that is used to confirm it is the correct directory. + * The search path for the package directory is currently only + * the parent and grandparent of the current working directory. + * If found, the command prints + * name_DIRPATH=<full path of located directory> + * and returns 0. If not found, does not print anything and returns 1. + */ +static int LocateDependency(const char *keypath) +{ + int i, ret; + static char *paths[] = {"..", "..\\..", "..\\..\\.."}; + + for (i = 0; i < (sizeof(paths)/sizeof(paths[0])); ++i) { + ret = LocateDependencyHelper(paths[i], keypath); + if (ret == 0) + return ret; + } + return ret; +} + + +/* * Local variables: * mode: c * c-basic-offset: 4 diff --git a/win/rules-ext.vc b/win/rules-ext.vc new file mode 100644 index 0000000..531e070 --- /dev/null +++ b/win/rules-ext.vc @@ -0,0 +1,118 @@ +# This file should only be included in makefiles for Tcl extensions,
+# NOT in the makefile for Tcl itself.
+
+!ifndef _RULES_EXT_VC
+
+# We need to run from the directory the parent makefile is located in.
+# nmake does not tell us what makefile was used to invoke it so parent
+# makefile has to set the MAKEFILEVC macro or we just make a guess and
+# warn if we think that is not the case.
+!if "$(MAKEFILEVC)" == ""
+
+!if exist("$(PROJECT).vc")
+MAKEFILEVC = $(PROJECT).vc
+!elseif exist("makefile.vc")
+MAKEFILEVC = makefile.vc
+!endif
+!endif # "$(MAKEFILEVC)" == ""
+
+!if !exist("$(MAKEFILEVC)")
+MSG = ^
+You must run nmake from the directory containing the project makefile.^
+If you are doing that and getting this message, set the MAKEFILEVC^
+macro to the name of the project makefile.
+!message WARNING: $(MSG)
+!endif
+
+!if "$(PROJECT)" == "tcl"
+!error The rules-ext.vc file is not intended for Tcl itself.
+!endif
+
+# We extract version numbers using the nmakehlp program. For now use
+# the local copy of nmakehlp. Once we locate Tcl, we will use that
+# one if it is newer.
+!if [$(CC) -nologo "nmakehlp.c" -link -subsystem:console > nul]
+!endif
+
+# First locate the Tcl directory that we are working with.
+!if "$(TCLDIR)" != ""
+
+_RULESDIR = $(TCLDIR:/=\)
+
+!else
+
+# If an installation path is specified, that is also the Tcl directory.
+# Also Tk never builds against an installed Tcl, it needs Tcl sources
+!if defined(INSTALLDIR) && "$(PROJECT)" != "tk"
+_RULESDIR=$(INSTALLDIR:/=\)
+!else
+# Locate Tcl sources
+!if [echo _RULESDIR = \> nmakehlp.out] \
+ || [nmakehlp -L generic\tcl.h >> nmakehlp.out]
+_RULESDIR = ..\..\tcl
+!else
+!include nmakehlp.out
+!endif
+
+!endif # defined(INSTALLDIR)....
+
+!endif # ifndef TCLDIR
+
+# Now look for the targets.vc file under the Tcl root. Note we check this
+# file and not rules.vc because the latter also exists on older systems.
+!if exist("$(_RULESDIR)\lib\nmake\targets.vc") # Building against installed Tcl
+_RULESDIR = $(_RULESDIR)\lib\nmake
+!elseif exist("$(_RULESDIR)\win\targets.vc") # Building against Tcl sources
+_RULESDIR = $(_RULESDIR)\win
+!else
+# If we have not located Tcl's targets file, most likely we are compiling
+# against an older version of Tcl and so must use our own support files.
+_RULESDIR = .
+!endif
+
+!if "$(_RULESDIR)" != "."
+# Potentially using Tcl's support files. If this extension has its own
+# nmake support files, need to compare the versions and pick newer.
+
+!if exist("rules.vc") # The extension has its own copy
+
+!if [echo TCL_RULES_MAJOR = \> versions.vc] \
+ && [nmakehlp -V "$(_RULESDIR)\rules.vc" RULES_VERSION_MAJOR >> versions.vc]
+!endif
+!if [echo TCL_RULES_MINOR = \>> versions.vc] \
+ && [nmakehlp -V "$(_RULESDIR)\rules.vc" RULES_VERSION_MINOR >> versions.vc]
+!endif
+
+!if [echo OUR_RULES_MAJOR = \>> versions.vc] \
+ && [nmakehlp -V "rules.vc" RULES_VERSION_MAJOR >> versions.vc]
+!endif
+!if [echo OUR_RULES_MINOR = \>> versions.vc] \
+ && [nmakehlp -V "rules.vc" RULES_VERSION_MINOR >> versions.vc]
+!endif
+!include versions.vc
+# We have a newer version of the support files, use them
+!if ($(TCL_RULES_MAJOR) != $(OUR_RULES_MAJOR)) || ($(TCL_RULES_MINOR) < $(OUR_RULES_MINOR))
+_RULESDIR = .
+!endif
+
+!endif # if exist("rules.vc")
+
+!endif # if $(_RULESDIR) != "."
+
+# Let rules.vc know what copy of nmakehlp.c to use.
+NMAKEHLPC = $(_RULESDIR)\nmakehlp.c
+
+# Get rid of our internal defines before calling rules.vc
+!undef TCL_RULES_MAJOR
+!undef TCL_RULES_MINOR
+!undef OUR_RULES_MAJOR
+!undef OUR_RULES_MINOR
+
+!if exist("$(_RULESDIR)\rules.vc")
+!message *** Using $(_RULESDIR)\rules.vc
+!include "$(_RULESDIR)\rules.vc"
+!else
+!error *** Could not locate rules.vc in $(_RULESDIR)
+!endif
+
+!endif # _RULES_EXT_VC
\ No newline at end of file diff --git a/win/rules.vc b/win/rules.vc index 33ebfe2..8db4752 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -1,60 +1,435 @@ -#------------------------------------------------------------------------------
+#------------------------------------------------------------- -*- makefile -*-
# rules.vc --
#
-# Microsoft Visual C++ makefile include for decoding the commandline
-# macros. This file does not need editing to build Tcl.
+# Part of the nmake based build system for Tcl and its extensions.
+# This file does all the hard work in terms of parsing build options,
+# compiler switches, defining common targets and macros. The Tcl makefile
+# directly includes this. Extensions include it via "rules-ext.vc".
+#
+# See TIP 477 (https://core.tcl.tk/tips/doc/trunk/tip/477.md) for
+# detailed documentation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# Copyright (c) 2001-2003 David Gravereaux.
# Copyright (c) 2003-2008 Patrick Thoyts
+# Copyright (c) 2017 Ashok P. Nadkarni
#------------------------------------------------------------------------------
!ifndef _RULES_VC
_RULES_VC = 1
-cc32 = $(CC) # built-in default.
-link32 = link
-lib32 = lib
-rc32 = $(RC) # built-in default.
+# The following macros define the version of the rules.vc nmake build system
+# For modifications that are not backward-compatible, you *must* change
+# the major version.
+RULES_VERSION_MAJOR = 1
+RULES_VERSION_MINOR = 2
-!ifndef INSTALLDIR
-### Assume the normal default.
-_INSTALLDIR = C:\Program Files\Tcl
+# The PROJECT macro must be defined by parent makefile.
+!if "$(PROJECT)" == ""
+!error *** Error: Macro PROJECT not defined! Please define it before including rules.vc
+!endif
+
+!if "$(PRJ_PACKAGE_TCLNAME)" == ""
+PRJ_PACKAGE_TCLNAME = $(PROJECT)
+!endif
+
+# Also special case Tcl and Tk to save some typing later
+DOING_TCL = 0
+DOING_TK = 0
+!if "$(PROJECT)" == "tcl"
+DOING_TCL = 1
+!elseif "$(PROJECT)" == "tk"
+DOING_TK = 1
+!endif
+
+!ifndef NEED_TK
+# Backwards compatibility
+!ifdef PROJECT_REQUIRES_TK
+NEED_TK = $(PROJECT_REQUIRES_TK)
!else
-### Fix the path separators.
-_INSTALLDIR = $(INSTALLDIR:/=\)
+NEED_TK = 0
+!endif
+!endif
+
+!ifndef NEED_TCL_SOURCE
+NEED_TCL_SOURCE = 0
!endif
+!ifdef NEED_TK_SOURCE
+!if $(NEED_TK_SOURCE)
+NEED_TK = 1
+!endif
+!else
+NEED_TK_SOURCE = 0
+!endif
+
+################################################################
+# Nmake is a pretty weak environment in syntax and capabilities
+# so this file is necessarily verbose. It's broken down into
+# the following parts.
+#
+# 0. Sanity check that compiler environment is set up and initialize
+# any built-in settings from the parent makefile
+# 1. First define the external tools used for compiling, copying etc.
+# as this is independent of everything else.
+# 2. Figure out our build structure in terms of the directory, whether
+# we are building Tcl or an extension, etc.
+# 3. Determine the compiler and linker versions
+# 4. Build the nmakehlp helper application
+# 5. Determine the supported compiler options and features
+# 6. Parse the OPTS macro value for user-specified build configuration
+# 7. Parse the STATS macro value for statistics instrumentation
+# 8. Parse the CHECKS macro for additional compilation checks
+# 9. Extract Tcl, and possibly Tk, version numbers from the headers
+# 10. Based on this selected configuration, construct the output
+# directory and file paths
+# 11. Construct the paths where the package is to be installed
+# 12. Set up the actual options passed to compiler and linker based
+# on the information gathered above.
+# 13. Define some standard build targets and implicit rules. These may
+# be optionally disabled by the parent makefile.
+# 14. (For extensions only.) Compare the configuration of the target
+# Tcl and the extensions and warn against discrepancies.
+#
+# One final note about the macro names used. They are as they are
+# for historical reasons. We would like legacy extensions to
+# continue to work with this make include file so be wary of
+# changing them for consistency or clarity.
+
+# 0. Sanity check compiler environment
+
+# Check to see we are configured to build with MSVC (MSDEVDIR, MSVCDIR or
+# VCINSTALLDIR) or with the MS Platform SDK (MSSDK or WindowsSDKDir)
+
+!if !defined(MSDEVDIR) && !defined(MSVCDIR) && !defined(VCINSTALLDIR) && !defined(MSSDK) && !defined(WINDOWSSDKDIR)
+MSG = ^
+Visual C++ compiler environment not initialized.
+!error $(MSG)
+!endif
+
+# We need to run from the directory the parent makefile is located in.
+# nmake does not tell us what makefile was used to invoke it so parent
+# makefile has to set the MAKEFILEVC macro or we just make a guess and
+# warn if we think that is not the case.
+!if "$(MAKEFILEVC)" == ""
+
+!if exist("$(PROJECT).vc")
+MAKEFILEVC = $(PROJECT).vc
+!elseif exist("makefile.vc")
+MAKEFILEVC = makefile.vc
+!endif
+!endif # "$(MAKEFILEVC)" == ""
+
+!if !exist("$(MAKEFILEVC)")
+MSG = ^
+You must run nmake from the directory containing the project makefile.^
+If you are doing that and getting this message, set the MAKEFILEVC^
+macro to the name of the project makefile.
+!message WARNING: $(MSG)
+!endif
+
+
+################################################################
+# 1. Define external programs being used
+
#----------------------------------------------------------
# Set the proper copy method to avoid overwrite questions
# to the user when copying files and selecting the right
# "delete all" method.
#----------------------------------------------------------
-!if "$(OS)" == "Windows_NT"
RMDIR = rmdir /S /Q
-ERRNULL = 2>NUL
-!if ![ver | find "4.0" > nul]
-CPY = echo y | xcopy /i >NUL
-COPY = copy >NUL
-!else
CPY = xcopy /i /y >NUL
+CPYDIR = xcopy /e /i /y >NUL
COPY = copy /y >NUL
+MKDIR = mkdir
+
+######################################################################
+# 2. Figure out our build environment in terms of what we're building.
+#
+# (a) Tcl itself
+# (b) Tk
+# (c) a Tcl extension using libraries/includes from an *installed* Tcl
+# (d) a Tcl extension using libraries/includes from Tcl source directory
+#
+# This last is needed because some extensions still need
+# some Tcl interfaces that are not publicly exposed.
+#
+# The fragment will set the following macros:
+# ROOT - root of this module sources
+# COMPATDIR - source directory that holds compatibility sources
+# DOCDIR - source directory containing documentation files
+# GENERICDIR - platform-independent source directory
+# WINDIR - Windows-specific source directory
+# TESTDIR - directory containing test files
+# TOOLSDIR - directory containing build tools
+# _TCLDIR - root of the Tcl installation OR the Tcl sources. Not set
+# when building Tcl itself.
+# _INSTALLDIR - native form of the installation path. For Tcl
+# this will be the root of the Tcl installation. For extensions
+# this will be the lib directory under the root.
+# TCLINSTALL - set to 1 if _TCLDIR refers to
+# headers and libraries from an installed Tcl, and 0 if built against
+# Tcl sources. Not set when building Tcl itself. Yes, not very well
+# named.
+# _TCL_H - native path to the tcl.h file
+#
+# If Tk is involved, also sets the following
+# _TKDIR - native form Tk installation OR Tk source. Not set if building
+# Tk itself.
+# TKINSTALL - set 1 if _TKDIR refers to installed Tk and 0 if Tk sources
+# _TK_H - native path to the tk.h file
+
+# Root directory for sources and assumed subdirectories
+ROOT = $(MAKEDIR)\..
+# The following paths CANNOT have spaces in them as they appear on the
+# left side of implicit rules.
+!ifndef COMPATDIR
+COMPATDIR = $(ROOT)\compat
+!endif
+!ifndef DOCDIR
+DOCDIR = $(ROOT)\doc
+!endif
+!ifndef GENERICDIR
+GENERICDIR = $(ROOT)\generic
+!endif
+!ifndef TOOLSDIR
+TOOLSDIR = $(ROOT)\tools
+!endif
+!ifndef TESTDIR
+TESTDIR = $(ROOT)\tests
+!endif
+!ifndef LIBDIR
+!if exist("$(ROOT)\library")
+LIBDIR = $(ROOT)\library
+!else
+LIBDIR = $(ROOT)\lib
!endif
-!else # "$(OS)" != "Windows_NT"
-CPY = xcopy /i >_JUNK.OUT # On Win98 NUL does not work here.
-COPY = copy >_JUNK.OUT # On Win98 NUL does not work here.
-RMDIR = deltree /Y
-NULL = \NUL # Used in testing directory existence
-ERRNULL = >NUL # Win9x shell cannot redirect stderr
!endif
-MKDIR = mkdir
+!ifndef DEMODIR
+!if exist("$(LIBDIR)\demos")
+DEMODIR = $(LIBDIR)\demos
+!else
+DEMODIR = $(ROOT)\demos
+!endif
+!endif # ifndef DEMODIR
+# Do NOT enclose WINDIR in a !ifndef because Windows always defines
+# WINDIR env var to point to c:\windows!
+# TBD - This is a potentially dangerous conflict, rename WINDIR to
+# something else
+WINDIR = $(ROOT)\win
+
+!ifndef RCDIR
+!if exist("$(WINDIR)\rc")
+RCDIR = $(WINDIR)\rc
+!else
+RCDIR = $(WINDIR)
+!endif
+!endif
+RCDIR = $(RCDIR:/=\)
-#------------------------------------------------------------------------------
-# Determine the host and target architectures and compiler version.
-#------------------------------------------------------------------------------
+# The target directory where the built packages and binaries will be installed.
+# INSTALLDIR is the (optional) path specified by the user.
+# _INSTALLDIR is INSTALLDIR using the backslash separator syntax
+!ifdef INSTALLDIR
+### Fix the path separators.
+_INSTALLDIR = $(INSTALLDIR:/=\)
+!else
+### Assume the normal default.
+_INSTALLDIR = $(HOMEDRIVE)\Tcl
+!endif
+
+!if $(DOING_TCL)
+
+# BEGIN Case 2(a) - Building Tcl itself
+
+# Only need to define _TCL_H
+_TCL_H = ..\generic\tcl.h
+
+# END Case 2(a) - Building Tcl itself
+
+!elseif $(DOING_TK)
+
+# BEGIN Case 2(b) - Building Tk
+
+TCLINSTALL = 0 # Tk always builds against Tcl source, not an installed Tcl
+!if "$(TCLDIR)" == ""
+!if [echo TCLDIR = \> nmakehlp.out] \
+ || [nmakehlp -L generic\tcl.h >> nmakehlp.out]
+!error *** Could not locate Tcl source directory.
+!endif
+!include nmakehlp.out
+!endif # TCLDIR == ""
+
+_TCLDIR = $(TCLDIR:/=\)
+_TCL_H = $(_TCLDIR)\generic\tcl.h
+!if !exist("$(_TCL_H)")
+!error Could not locate tcl.h. Please set the TCLDIR macro to point to the Tcl *source* directory.
+!endif
+
+_TK_H = ..\generic\tk.h
+
+# END Case 2(b) - Building Tk
+
+!else
+
+# BEGIN Case 2(c) or (d) - Building an extension other than Tk
+
+# If command line has specified Tcl location through TCLDIR, use it
+# else default to the INSTALLDIR setting
+!if "$(TCLDIR)" != ""
+
+_TCLDIR = $(TCLDIR:/=\)
+!if exist("$(_TCLDIR)\include\tcl.h") # Case 2(c) with TCLDIR defined
+TCLINSTALL = 1
+_TCL_H = $(_TCLDIR)\include\tcl.h
+!elseif exist("$(_TCLDIR)\generic\tcl.h") # Case 2(d) with TCLDIR defined
+TCLINSTALL = 0
+_TCL_H = $(_TCLDIR)\generic\tcl.h
+!endif
+
+!else # # Case 2(c) for extensions with TCLDIR undefined
+
+# Need to locate Tcl depending on whether it needs Tcl source or not.
+# If we don't, check the INSTALLDIR for an installed Tcl first
+
+!if exist("$(_INSTALLDIR)\include\tcl.h") && !$(NEED_TCL_SOURCE)
+
+TCLINSTALL = 1
+TCLDIR = $(_INSTALLDIR)\..
+# NOTE: we will be resetting _INSTALLDIR to _INSTALLDIR/lib for extensions
+# later so the \.. accounts for the /lib
+_TCLDIR = $(_INSTALLDIR)\..
+_TCL_H = $(_TCLDIR)\include\tcl.h
+
+!else # exist(...) && ! $(NEED_TCL_SOURCE)
+
+!if [echo _TCLDIR = \> nmakehlp.out] \
+ || [nmakehlp -L generic\tcl.h >> nmakehlp.out]
+!error *** Could not locate Tcl source directory.
+!endif
+!include nmakehlp.out
+TCLINSTALL = 0
+TCLDIR = $(_TCLDIR)
+_TCL_H = $(_TCLDIR)\generic\tcl.h
+
+!endif # exist(...) && ! $(NEED_TCL_SOURCE)
+
+!endif # TCLDIR
+
+!ifndef _TCL_H
+MSG =^
+Failed to find tcl.h. The TCLDIR macro is set incorrectly or is not set and default path does not contain tcl.h.
+!error $(MSG)
+!endif
+
+# Now do the same to locate Tk headers and libs if project requires Tk
+!if $(NEED_TK)
+
+!if "$(TKDIR)" != ""
+
+_TKDIR = $(TKDIR:/=\)
+!if exist("$(_TKDIR)\include\tk.h")
+TKINSTALL = 1
+_TK_H = $(_TKDIR)\include\tk.h
+!elseif exist("$(_TKDIR)\generic\tk.h")
+TKINSTALL = 0
+_TK_H = $(_TKDIR)\generic\tk.h
+!endif
+
+!else # TKDIR not defined
+
+# Need to locate Tcl depending on whether it needs Tcl source or not.
+# If we don't, check the INSTALLDIR for an installed Tcl first
+
+!if exist("$(_INSTALLDIR)\include\tk.h") && !$(NEED_TK_SOURCE)
+
+TKINSTALL = 1
+# NOTE: we will be resetting _INSTALLDIR to _INSTALLDIR/lib for extensions
+# later so the \.. accounts for the /lib
+_TKDIR = $(_INSTALLDIR)\..
+_TK_H = $(_TKDIR)\include\tk.h
+TKDIR = $(_TKDIR)
+
+!else # exist("$(_INSTALLDIR)\include\tk.h") && !$(NEED_TK_SOURCE)
+
+!if [echo _TKDIR = \> nmakehlp.out] \
+ || [nmakehlp -L generic\tk.h >> nmakehlp.out]
+!error *** Could not locate Tk source directory.
+!endif
+!include nmakehlp.out
+TKINSTALL = 0
+TKDIR = $(_TKDIR)
+_TK_H = $(_TKDIR)\generic\tk.h
+
+!endif # exist("$(_INSTALLDIR)\include\tk.h") && !$(NEED_TK_SOURCE)
+
+!endif # TKDIR
+
+!ifndef _TK_H
+MSG =^
+Failed to find tk.h. The TKDIR macro is set incorrectly or is not set and default path does not contain tk.h.
+!error $(MSG)
+!endif
+
+!endif # NEED_TK
+
+!if $(NEED_TCL_SOURCE) && $(TCLINSTALL)
+MSG = ^
+*** Warning: This extension requires the source distribution of Tcl.^
+*** Please set the TCLDIR macro to point to the Tcl sources.
+!error $(MSG)
+!endif
+
+!if $(NEED_TK_SOURCE)
+!if $(TKINSTALL)
+MSG = ^
+*** Warning: This extension requires the source distribution of Tk.^
+*** Please set the TKDIR macro to point to the Tk sources.
+!error $(MSG)
+!endif
+!endif
+
+
+# If INSTALLDIR set to Tcl installation root dir then reset to the
+# lib dir for installing extensions
+!if exist("$(_INSTALLDIR)\include\tcl.h")
+_INSTALLDIR=$(_INSTALLDIR)\lib
+!endif
+
+# END Case 2(c) or (d) - Building an extension
+!endif # if $(DOING_TCL)
+
+################################################################
+# 3. Determine compiler version and architecture
+# In this section, we figure out the compiler version and the
+# architecture for which we are building. This sets the
+# following macros:
+# VCVERSION - the internal compiler version as 1200, 1400, 1910 etc.
+# This is also printed by the compiler in dotted form 19.10 etc.
+# VCVER - the "marketing version", for example Visual C++ 6 for internal
+# compiler version 1200. This is kept only for legacy reasons as it
+# does not make sense for recent Microsoft compilers. Only used for
+# output directory names.
+# ARCH - set to IX86 or AMD64 depending on 32- or 64-bit target
+# NATIVE_ARCH - set to IX86 or AMD64 for the host machine
+# MACHINE - same as $(ARCH) - legacy
+# _VC_MANIFEST_EMBED_{DLL,EXE} - commands for embedding a manifest if needed
+# CFG_ENCODING - set to an character encoding.
+# TBD - this is passed to compiler as TCL_CFGVAL_ENCODING but can't
+# see where it is used
+
+cc32 = $(CC) # built-in default.
+link32 = link
+lib32 = lib
+rc32 = $(RC) # built-in default.
+
+#----------------------------------------------------------------
+# Figure out the compiler architecture and version by writing
+# the C macros to a file, preprocessing them with the C
+# preprocessor and reading back the created file
_HASH=^#
_VC_MANIFEST_EMBED_EXE=
@@ -66,16 +441,43 @@ VCVER=0 && ![echo $(_HASH)elif defined(_M_AMD64) >> vercl.x] \
&& ![echo ARCH=AMD64 >> vercl.x] \
&& ![echo $(_HASH)endif >> vercl.x] \
- && ![cl -nologo -TC -P vercl.x $(ERRNULL)]
+ && ![$(cc32) -nologo -TC -P vercl.x 2>NUL]
!include vercl.i
+!if $(VCVERSION) < 1900
!if ![echo VCVER= ^\> vercl.vc] \
&& ![set /a $(VCVERSION) / 100 - 6 >> vercl.vc]
!include vercl.vc
!endif
+!else
+# The simple calculation above does not apply to new Visual Studio releases
+# Keep the compiler version in its native form.
+VCVER = $(VCVERSION)
!endif
-!if ![del $(ERRNUL) /q/f vercl.x vercl.i vercl.vc]
!endif
+!if ![del 2>NUL /q/f vercl.x vercl.i vercl.vc]
+!endif
+
+#----------------------------------------------------------------
+# The MACHINE macro is used by legacy makefiles so set it as well
+!ifdef MACHINE
+!if "$(MACHINE)" == "x86"
+!undef MACHINE
+MACHINE = IX86
+!elseif "$(MACHINE)" == "x64"
+!undef MACHINE
+MACHINE = AMD64
+!endif
+!if "$(MACHINE)" != "$(ARCH)"
+!error Specified MACHINE macro $(MACHINE) does not match detected target architecture $(ARCH).
+!endif
+!else
+MACHINE=$(ARCH)
+!endif
+
+#------------------------------------------------------------
+# Figure out the *host* architecture by reading the registry
+
!if ![reg query HKLM\Hardware\Description\System\CentralProcessor\0 /v Identifier | findstr /i x86]
NATIVE_ARCH=IX86
!else
@@ -88,153 +490,227 @@ _VC_MANIFEST_EMBED_EXE=if exist $@.manifest mt -nologo -manifest $@.manifest -ou _VC_MANIFEST_EMBED_DLL=if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;2
!endif
-!ifndef MACHINE
-MACHINE=$(ARCH)
-!endif
-
!ifndef CFG_ENCODING
CFG_ENCODING = \"cp1252\"
!endif
-!message ===============================================================================
+################################################################
+# 4. Build the nmakehlp program
+# This is a helper app we need to overcome nmake's limiting
+# environment. We will call out to it to get various bits of
+# information about supported compiler options etc.
+#
+# Tcl itself will always use the nmakehlp.c program which is
+# in its own source. This is the "master" copy and kept updated.
+#
+# Extensions built against an installed Tcl will use the installed
+# copy of Tcl's nmakehlp.c if there is one and their own version
+# otherwise. In the latter case, they would also be using their own
+# rules.vc. Note that older versions of Tcl do not install nmakehlp.c
+# or rules.vc.
+#
+# Extensions built against Tcl sources will use the one from the Tcl source.
+#
+# When building an extension using a sufficiently new version of Tcl,
+# rules-ext.vc will define NMAKEHLPC appropriately to point to the
+# copy of nmakehlp.c to be used.
-#----------------------------------------------------------
-# build the helper app we need to overcome nmake's limiting
-# environment.
-#----------------------------------------------------------
+!ifndef NMAKEHLPC
+# Default to the one in the current directory (the extension's own nmakehlp.c)
+NMAKEHLPC = nmakehlp.c
-!if !exist(nmakehlp.exe)
-!if [$(cc32) -nologo nmakehlp.c -link -subsystem:console > nul]
+!if !$(DOING_TCL)
+!if $(TCLINSTALL)
+!if exist("$(_TCLDIR)\lib\nmake\nmakehlp.c")
+NMAKEHLPC = $(_TCLDIR)\lib\nmake\nmakehlp.c
!endif
+!else # ! $(TCLINSTALL)
+!if exist("$(_TCLDIR)\win\nmakehlp.c")
+NMAKEHLPC = $(_TCLDIR)\win\nmakehlp.c
!endif
+!endif # $(TCLINSTALL)
+!endif # !$(DOING_TCL)
-#----------------------------------------------------------
-# Test for compiler features
-#----------------------------------------------------------
+!endif # NMAKEHLPC
-### test for optimizations
-!if [nmakehlp -c -Ot]
-!message *** Compiler has 'Optimizations'
-OPTIMIZING = 1
-!else
-!message *** Compiler does not have 'Optimizations'
-OPTIMIZING = 0
+# We always build nmakehlp even if it exists since we do not know
+# what source it was built from.
+!if [$(cc32) -nologo "$(NMAKEHLPC)" -link -subsystem:console > nul]
!endif
-OPTIMIZATIONS =
+################################################################
+# 5. Test for compiler features
+# Visual C++ compiler options have changed over the years. Check
+# which options are supported by the compiler in use.
+#
+# The following macros are set:
+# OPTIMIZATIONS - the compiler flags to be used for optimized builds
+# DEBUGFLAGS - the compiler flags to be used for debug builds
+# LINKERFLAGS - Flags passed to the linker
+#
+# Note that these are the compiler settings *available*, not those
+# that will be *used*. The latter depends on the OPTS macro settings
+# which we have not yet parsed.
+#
+# Also note that some of the flags in OPTIMIZATIONS are not really
+# related to optimization. They are placed there only for legacy reasons
+# as some extensions expect them to be included in that macro.
-!if [nmakehlp -c -Ot]
-OPTIMIZATIONS = $(OPTIMIZATIONS) -Ot
+# -Op improves float consistency. Note only needed for older compilers
+# Newer compilers do not need or support this option.
+!if [nmakehlp -c -Op]
+FPOPTS = -Op
!endif
-!if [nmakehlp -c -Oi]
-OPTIMIZATIONS = $(OPTIMIZATIONS) -Oi
+# Strict floating point semantics - present in newer compilers in lieu of -Op
+!if [nmakehlp -c -fp:strict]
+FPOPTS = $(FPOPTS) -fp:strict
!endif
-!if [nmakehlp -c -Op]
-OPTIMIZATIONS = $(OPTIMIZATIONS) -Op
+!if "$(MACHINE)" == "IX86"
+### test for pentium errata
+!if [nmakehlp -c -QI0f]
+!message *** Compiler has 'Pentium 0x0f fix'
+FPOPTS = $(FPOPTS) -QI0f
+!else
+!message *** Compiler does not have 'Pentium 0x0f fix'
!endif
-
-!if [nmakehlp -c -fp:strict]
-OPTIMIZATIONS = $(OPTIMIZATIONS) -fp:strict
!endif
-!if [nmakehlp -c -Gs]
-OPTIMIZATIONS = $(OPTIMIZATIONS) -Gs
+### test for optimizations
+# /O2 optimization includes /Og /Oi /Ot /Oy /Ob2 /Gs /GF /Gy as per
+# documentation. Note we do NOT want /Gs as that inserts a _chkstk
+# stack probe at *every* function entry, not just those with more than
+# a page of stack allocation resulting in a performance hit. However,
+# /O2 documentation is misleading as its stack probes are simply the
+# default page size locals allocation probes and not what is implied
+# by an explicit /Gs option.
+
+OPTIMIZATIONS = $(FPOPTS)
+
+!if [nmakehlp -c -O2]
+OPTIMIZING = 1
+OPTIMIZATIONS = $(OPTIMIZATIONS) -O2
+!else
+# Legacy, really. All modern compilers support this
+!message *** Compiler does not have 'Optimizations'
+OPTIMIZING = 0
!endif
+# Checks for buffer overflows in local arrays
!if [nmakehlp -c -GS]
OPTIMIZATIONS = $(OPTIMIZATIONS) -GS
!endif
+# Link time optimization. Note that this option (potentially) makes
+# generated libraries only usable by the specific VC++ version that
+# created it. Requires /LTCG linker option
!if [nmakehlp -c -GL]
OPTIMIZATIONS = $(OPTIMIZATIONS) -GL
+CC_GL_OPT_ENABLED = 1
+!else
+# In newer compilers -GL and -YX are incompatible.
+!if [nmakehlp -c -YX]
+OPTIMIZATIONS = $(OPTIMIZATIONS) -YX
!endif
+!endif # [nmakehlp -c -GL]
-DEBUGFLAGS =
+DEBUGFLAGS = $(FPOPTS)
+# Run time error checks. Not available or valid in a release, non-debug build
+# RTC is for modern compilers, -GZ is legacy
!if [nmakehlp -c -RTC1]
DEBUGFLAGS = $(DEBUGFLAGS) -RTC1
!elseif [nmakehlp -c -GZ]
DEBUGFLAGS = $(DEBUGFLAGS) -GZ
!endif
-COMPILERFLAGS =-W3 /D_ATL_XP_TARGETING
-
-# In v13 -GL and -YX are incompatible.
-!if [nmakehlp -c -YX]
-!if ![nmakehlp -c -GL]
-OPTIMIZATIONS = $(OPTIMIZATIONS) -YX
-!endif
-!endif
-
-!if "$(MACHINE)" == "IX86"
-### test for pentium errata
-!if [nmakehlp -c -QI0f]
-!message *** Compiler has 'Pentium 0x0f fix'
-COMPILERFLAGS = $(COMPILERFLAGS) -QI0f
-!else
-!message *** Compiler does not have 'Pentium 0x0f fix'
-!endif
-!endif
-
-!if "$(MACHINE)" == "IA64"
-### test for Itanium errata
-!if [nmakehlp -c -QIA64_Bx]
-!message *** Compiler has 'B-stepping errata workarounds'
-COMPILERFLAGS = $(COMPILERFLAGS) -QIA64_Bx
-!else
-!message *** Compiler does not have 'B-stepping errata workarounds'
-!endif
-!endif
+#----------------------------------------------------------------
+# Linker flags
-# Prevents "LNK1561: entry point must be defined" error compiling from VS-IDE:
+# LINKER_TESTFLAGS are for internal use when we call nmakehlp to test
+# if the linker supports a specific option. Without these flags link will
+# return "LNK1561: entry point must be defined" error compiling from VS-IDE:
+# They are not passed through to the actual application / extension
+# link rules.
!ifndef LINKER_TESTFLAGS
-LINKER_TESTFLAGS = /DLL /NOENTRY /OUT:nmhlp-out.txt
-!endif
-
-!if "$(MACHINE)" == "IX86"
-### test for -align:4096, when align:512 will do.
-!if [nmakehlp -l -opt:nowin98 $(LINKER_TESTFLAGS)]
-!message *** Linker has 'Win98 alignment problem'
-ALIGN98_HACK = 1
-!else
-!message *** Linker does not have 'Win98 alignment problem'
-ALIGN98_HACK = 0
-!endif
-!else
-ALIGN98_HACK = 0
+LINKER_TESTFLAGS = /DLL /NOENTRY /OUT:nmakehlp.out
!endif
LINKERFLAGS =
+# If compiler has enabled link time optimization, linker must too with -ltcg
+!ifdef CC_GL_OPT_ENABLED
!if [nmakehlp -l -ltcg $(LINKER_TESTFLAGS)]
-LINKERFLAGS =-ltcg
-!endif
-
-#----------------------------------------------------------
-# Decode the options requested.
-#----------------------------------------------------------
-
-!if "$(OPTS)" == "" || [nmakehlp -f "$(OPTS)" "none"]
+LINKERFLAGS = $(LINKERFLAGS) -ltcg
+!endif
+!endif
+
+########################################################################
+# 6. Parse the OPTS macro to work out the requested build configuration.
+# Based on this, we will construct the actual switches to be passed to the
+# compiler and linker using the macros defined in the previous section.
+# The following macros are defined by this section based on OPTS
+# STATIC_BUILD - 0 -> Tcl is to be built as a shared library
+# 1 -> build as a static library and shell
+# TCL_THREADS - legacy but always 1 on Windows since winsock requires it.
+# DEBUG - 1 -> debug build, 0 -> release builds
+# SYMBOLS - 1 -> generate PDB's, 0 -> no PDB's
+# PROFILE - 1 -> generate profiling info, 0 -> no profiling
+# PGO - 1 -> profile based optimization, 0 -> no
+# MSVCRT - 1 -> link to dynamic C runtime even when building static Tcl build
+# 0 -> link to static C runtime for static Tcl build.
+# Does not impact shared Tcl builds (STATIC_BUILD == 0)
+# TCL_USE_STATIC_PACKAGES - 1 -> statically link the registry and dde extensions
+# in the Tcl shell. 0 -> keep them as shared libraries
+# Does not impact shared Tcl builds.
+# USE_THREAD_ALLOC - 1 -> Use a shared global free pool for allocation.
+# 0 -> Use the non-thread allocator.
+# UNCHECKED - 1 -> when doing a debug build with symbols, use the release
+# C runtime, 0 -> use the debug C runtime.
+# USE_STUBS - 1 -> compile to use stubs interfaces, 0 -> direct linking
+# CONFIG_CHECK - 1 -> check current build configuration against Tcl
+# configuration (ignored for Tcl itself)
+# Further, LINKERFLAGS are modified based on above.
+
+# Default values for all the above
STATIC_BUILD = 0
-TCL_THREADS = 0
+TCL_THREADS = 1
DEBUG = 0
SYMBOLS = 0
PROFILE = 0
PGO = 0
MSVCRT = 1
-LOIMPACT = 0
TCL_USE_STATIC_PACKAGES = 0
-USE_THREAD_ALLOC = 0
+USE_THREAD_ALLOC = 1
UNCHECKED = 0
+CONFIG_CHECK = 1
+!if $(DOING_TCL)
+USE_STUBS = 0
!else
+USE_STUBS = 1
+!endif
+
+# If OPTS is not empty AND does not contain "none" which turns off all OPTS
+# set the above macros based on OPTS content
+!if "$(OPTS)" != "" && ![nmakehlp -f "$(OPTS)" "none"]
+
+# OPTS are specified, parse them
+
!if [nmakehlp -f $(OPTS) "static"]
!message *** Doing static
STATIC_BUILD = 1
-!else
-STATIC_BUILD = 0
!endif
+
+!if [nmakehlp -f $(OPTS) "nostubs"]
+!message *** Not using stubs
+USE_STUBS = 0
+!endif
+
+!if [nmakehlp -f $(OPTS) "nomsvcrt"]
+!message *** Doing nomsvcrt
+MSVCRT = 0
+!else
!if [nmakehlp -f $(OPTS) "msvcrt"]
!message *** Doing msvcrt
MSVCRT = 1
@@ -245,38 +721,45 @@ MSVCRT = 1 MSVCRT = 0
!endif
!endif
+!endif # [nmakehlp -f $(OPTS) "nomsvcrt"]
+
!if [nmakehlp -f $(OPTS) "staticpkg"] && $(STATIC_BUILD)
!message *** Doing staticpkg
TCL_USE_STATIC_PACKAGES = 1
!else
TCL_USE_STATIC_PACKAGES = 0
!endif
-!if [nmakehlp -f $(OPTS) "threads"]
-!message *** Doing threads
-TCL_THREADS = 1
-USE_THREAD_ALLOC = 1
-!else
+
+!if [nmakehlp -f $(OPTS) "nothreads"]
+!message *** Compile explicitly for non-threaded tcl
TCL_THREADS = 0
-USE_THREAD_ALLOC = 0
+USE_THREAD_ALLOC= 0
+!else
+TCL_THREADS = 1
+USE_THREAD_ALLOC= 1
!endif
+
!if [nmakehlp -f $(OPTS) "symbols"]
!message *** Doing symbols
DEBUG = 1
!else
DEBUG = 0
!endif
+
!if [nmakehlp -f $(OPTS) "pdbs"]
!message *** Doing pdbs
SYMBOLS = 1
!else
SYMBOLS = 0
!endif
+
!if [nmakehlp -f $(OPTS) "profile"]
!message *** Doing profile
PROFILE = 1
!else
PROFILE = 0
!endif
+
!if [nmakehlp -f $(OPTS) "pgi"]
!message *** Doing profile guided optimization instrumentation
PGO = 1
@@ -286,44 +769,229 @@ PGO = 2 !else
PGO = 0
!endif
+
!if [nmakehlp -f $(OPTS) "loimpact"]
-!message *** Doing loimpact
-LOIMPACT = 1
-!else
-LOIMPACT = 0
+!message *** Warning: ignoring option "loimpact" - deprecated on modern Windows.
!endif
+
+# TBD - should get rid of this option
!if [nmakehlp -f $(OPTS) "thrdalloc"]
!message *** Doing thrdalloc
USE_THREAD_ALLOC = 1
!endif
+
!if [nmakehlp -f $(OPTS) "tclalloc"]
-!message *** Doing tclalloc
USE_THREAD_ALLOC = 0
!endif
+
!if [nmakehlp -f $(OPTS) "unchecked"]
!message *** Doing unchecked
UNCHECKED = 1
!else
UNCHECKED = 0
!endif
+
+!if [nmakehlp -f $(OPTS) "noconfigcheck"]
+CONFIG_CHECK = 1
+!else
+CONFIG_CHECK = 0
!endif
-#----------------------------------------------------------
-# Figure-out how to name our intermediate and output directories.
-# We wouldn't want different builds to use the same .obj files
-# by accident.
-#----------------------------------------------------------
+!endif # "$(OPTS)" != "" && ... parsing of OPTS
+
+# Set linker flags based on above
+
+!if $(PGO) > 1
+!if [nmakehlp -l -ltcg:pgoptimize $(LINKER_TESTFLAGS)]
+LINKERFLAGS = $(LINKERFLAGS:-ltcg=) -ltcg:pgoptimize
+!else
+MSG=^
+This compiler does not support profile guided optimization.
+!error $(MSG)
+!endif
+!elseif $(PGO) > 0
+!if [nmakehlp -l -ltcg:pginstrument $(LINKER_TESTFLAGS)]
+LINKERFLAGS = $(LINKERFLAGS:-ltcg=) -ltcg:pginstrument
+!else
+MSG=^
+This compiler does not support profile guided optimization.
+!error $(MSG)
+!endif
+!endif
+
+################################################################
+# 7. Parse the STATS macro to configure code instrumentation
+# The following macros are set by this section:
+# TCL_MEM_DEBUG - 1 -> enables memory allocation instrumentation
+# 0 -> disables
+# TCL_COMPILE_DEBUG - 1 -> enables byte compiler logging
+# 0 -> disables
+
+# Default both are off
+TCL_MEM_DEBUG = 0
+TCL_COMPILE_DEBUG = 0
-#----------------------------------------
-# Naming convention:
+!if "$(STATS)" != "" && ![nmakehlp -f "$(STATS)" "none"]
+
+!if [nmakehlp -f $(STATS) "memdbg"]
+!message *** Doing memdbg
+TCL_MEM_DEBUG = 1
+!else
+TCL_MEM_DEBUG = 0
+!endif
+
+!if [nmakehlp -f $(STATS) "compdbg"]
+!message *** Doing compdbg
+TCL_COMPILE_DEBUG = 1
+!else
+TCL_COMPILE_DEBUG = 0
+!endif
+
+!endif
+
+####################################################################
+# 8. Parse the CHECKS macro to configure additional compiler checks
+# The following macros are set by this section:
+# WARNINGS - compiler switches that control the warnings level
+# TCL_NO_DEPRECATED - 1 -> disable support for deprecated functions
+# 0 -> enable deprecated functions
+
+# Defaults - Permit deprecated functions and warning level 3
+TCL_NO_DEPRECATED = 0
+WARNINGS = -W3
+
+!if "$(CHECKS)" != "" && ![nmakehlp -f "$(CHECKS)" "none"]
+
+!if [nmakehlp -f $(CHECKS) "nodep"]
+!message *** Doing nodep check
+TCL_NO_DEPRECATED = 1
+!endif
+
+!if [nmakehlp -f $(CHECKS) "fullwarn"]
+!message *** Doing full warnings check
+WARNINGS = -W4
+!if [nmakehlp -l -warn:3 $(LINKER_TESTFLAGS)]
+LINKERFLAGS = $(LINKERFLAGS) -warn:3
+!endif
+!endif
+
+!if [nmakehlp -f $(CHECKS) "64bit"] && [nmakehlp -c -Wp64]
+!message *** Doing 64bit portability warnings
+WARNINGS = $(WARNINGS) -Wp64
+!endif
+
+!endif
+
+################################################################
+# 9. Extract various version numbers
+# For Tcl and Tk, version numbers are extracted from tcl.h and tk.h
+# respectively. For extensions, versions are extracted from the
+# configure.in or configure.ac from the TEA configuration if it
+# exists, and unset otherwise.
+# Sets the following macros:
+# TCL_MAJOR_VERSION
+# TCL_MINOR_VERSION
+# TCL_PATCH_LEVEL
+# TCL_VERSION
+# TK_MAJOR_VERSION
+# TK_MINOR_VERSION
+# TK_PATCH_LEVEL
+# TK_VERSION
+# DOTVERSION - set as (for example) 2.5
+# VERSION - set as (for example 25)
+#--------------------------------------------------------------
+
+!if [echo REM = This file is generated from rules.vc > versions.vc]
+!endif
+!if [echo TCL_MAJOR_VERSION = \>> versions.vc] \
+ && [nmakehlp -V "$(_TCL_H)" TCL_MAJOR_VERSION >> versions.vc]
+!endif
+!if [echo TCL_MINOR_VERSION = \>> versions.vc] \
+ && [nmakehlp -V "$(_TCL_H)" TCL_MINOR_VERSION >> versions.vc]
+!endif
+!if [echo TCL_PATCH_LEVEL = \>> versions.vc] \
+ && [nmakehlp -V "$(_TCL_H)" TCL_PATCH_LEVEL >> versions.vc]
+!endif
+
+!if defined(_TK_H)
+!if [echo TK_MAJOR_VERSION = \>> versions.vc] \
+ && [nmakehlp -V $(_TK_H) TK_MAJOR_VERSION >> versions.vc]
+!endif
+!if [echo TK_MINOR_VERSION = \>> versions.vc] \
+ && [nmakehlp -V $(_TK_H) TK_MINOR_VERSION >> versions.vc]
+!endif
+!if [echo TK_PATCH_LEVEL = \>> versions.vc] \
+ && [nmakehlp -V $(_TK_H) TK_PATCH_LEVEL >> versions.vc]
+!endif
+!endif # _TK_H
+
+!include versions.vc
+
+TCL_VERSION = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION)
+TCL_DOTVERSION = $(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION)
+!if defined(_TK_H)
+TK_VERSION = $(TK_MAJOR_VERSION)$(TK_MINOR_VERSION)
+TK_DOTVERSION = $(TK_MAJOR_VERSION).$(TK_MINOR_VERSION)
+!endif
+
+# Set DOTVERSION and VERSION
+!if $(DOING_TCL)
+
+DOTVERSION = $(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION)
+VERSION = $(TCL_VERSION)
+
+!elseif $(DOING_TK)
+
+DOTVERSION = $(TK_DOTVERSION)
+VERSION = $(TK_VERSION)
+
+!else # Doing a non-Tk extension
+
+# If parent makefile has not defined DOTVERSION, try to get it from TEA
+# first from a configure.in file, and then from configure.ac
+!ifndef DOTVERSION
+!if [echo DOTVERSION = \> versions.vc] \
+ || [nmakehlp -V $(ROOT)\configure.in ^[$(PROJECT)^] >> versions.vc]
+!if [echo DOTVERSION = \> versions.vc] \
+ || [nmakehlp -V $(ROOT)\configure.ac ^[$(PROJECT)^] >> versions.vc]
+!error *** Could not figure out extension version. Please define DOTVERSION in parent makefile before including rules.vc.
+!endif
+!endif
+!include versions.vc
+!endif # DOTVERSION
+VERSION = $(DOTVERSION:.=)
+
+!endif # $(DOING_TCL) ... etc.
+
+################################################################
+# 10. Construct output directory and file paths
+# Figure-out how to name our intermediate and output directories.
+# In order to avoid inadvertent mixing of object files built using
+# different compilers, build configurations etc.,
+#
+# Naming convention (suffixes):
# t = full thread support.
-# s = static library (as opposed to an
-# import library)
-# g = linked to the debug enabled C
-# run-time.
-# x = special static build when it
-# links to the dynamic C run-time.
-#----------------------------------------
+# s = static library (as opposed to an import library)
+# g = linked to the debug enabled C run-time.
+# x = special static build when it links to the dynamic C run-time.
+#
+# The following macros are set in this section:
+# SUFX - the suffix to use for binaries based on above naming convention
+# BUILDDIRTOP - the toplevel default output directory
+# is of the form {Release,Debug}[_AMD64][_COMPILERVERSION]
+# TMP_DIR - directory where object files are created
+# OUT_DIR - directory where output executables are created
+# Both TMP_DIR and OUT_DIR are defaulted only if not defined by the
+# parent makefile (or command line). The default values are
+# based on BUILDDIRTOP.
+# STUBPREFIX - name of the stubs library for this project
+# PRJIMPLIB - output path of the generated project import library
+# PRJLIBNAME - name of generated project library
+# PRJLIB - output path of generated project library
+# PRJSTUBLIBNAME - name of the generated project stubs library
+# PRJSTUBLIB - output path of the generated project stubs library
+# RESFILE - output resource file (only if not static build)
+
SUFX = tsgx
!if $(DEBUG)
@@ -376,80 +1044,217 @@ OUT_DIR = $(TMP_DIR) !endif
!endif
-
-#----------------------------------------------------------
-# Decode the statistics requested.
-#----------------------------------------------------------
-
-!if "$(STATS)" == "" || [nmakehlp -f "$(STATS)" "none"]
-TCL_MEM_DEBUG = 0
-TCL_COMPILE_DEBUG = 0
-!else
-!if [nmakehlp -f $(STATS) "memdbg"]
-!message *** Doing memdbg
-TCL_MEM_DEBUG = 1
-!else
-TCL_MEM_DEBUG = 0
-!endif
-!if [nmakehlp -f $(STATS) "compdbg"]
-!message *** Doing compdbg
-TCL_COMPILE_DEBUG = 1
-!else
-TCL_COMPILE_DEBUG = 0
+# Relative paths -> absolute
+!if [echo OUT_DIR = \> nmakehlp.out] \
+ || [nmakehlp -Q "$(OUT_DIR)" >> nmakehlp.out]
+!error *** Could not fully qualify path OUT_DIR=$(OUT_DIR)
!endif
+!if [echo TMP_DIR = \>> nmakehlp.out] \
+ || [nmakehlp -Q "$(TMP_DIR)" >> nmakehlp.out]
+!error *** Could not fully qualify path TMP_DIR=$(TMP_DIR)
!endif
+!include nmakehlp.out
+# The name of the stubs library for the project being built
+STUBPREFIX = $(PROJECT)stub
-#----------------------------------------------------------
-# Decode the checks requested.
-#----------------------------------------------------------
+# Set up paths to various Tcl executables and libraries needed by extensions
+!if $(DOING_TCL)
-!if "$(CHECKS)" == "" || [nmakehlp -f "$(CHECKS)" "none"]
-TCL_NO_DEPRECATED = 0
-WARNINGS = -W3
-!else
-!if [nmakehlp -f $(CHECKS) "nodep"]
-!message *** Doing nodep check
-TCL_NO_DEPRECATED = 1
-!else
-TCL_NO_DEPRECATED = 0
+TCLSHNAME = $(PROJECT)sh$(TCL_VERSION)$(SUFX).exe
+TCLSH = $(OUT_DIR)\$(TCLSHNAME)
+TCLIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib
+TCLLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT)
+TCLLIB = $(OUT_DIR)\$(TCLLIBNAME)
+
+TCLSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib
+TCLSTUBLIB = $(OUT_DIR)\$(TCLSTUBLIBNAME)
+TCL_INCLUDES = -I"$(WINDIR)" -I"$(GENERICDIR)"
+
+!else # ! $(DOING_TCL)
+
+!if $(TCLINSTALL) # Building against an installed Tcl
+
+# When building extensions, we need to locate tclsh. Depending on version
+# of Tcl we are building against, this may or may not have a "t" suffix.
+# Try various possibilities in turn.
+TCLSH = $(_TCLDIR)\bin\tclsh$(TCL_VERSION)$(SUFX).exe
+!if !exist("$(TCLSH)") && $(TCL_THREADS)
+TCLSH = $(_TCLDIR)\bin\tclsh$(TCL_VERSION)t$(SUFX).exe
!endif
-!if [nmakehlp -f $(CHECKS) "fullwarn"]
-!message *** Doing full warnings check
-WARNINGS = -W4
-!if [nmakehlp -l -warn:3 $(LINKER_TESTFLAGS)]
-LINKERFLAGS = $(LINKERFLAGS) -warn:3
+!if !exist("$(TCLSH)")
+TCLSH = $(_TCLDIR)\bin\tclsh$(TCL_VERSION)$(SUFX:t=).exe
!endif
-!else
-WARNINGS = -W3
+
+TCLSTUBLIB = $(_TCLDIR)\lib\tclstub$(TCL_VERSION).lib
+TCLIMPLIB = $(_TCLDIR)\lib\tcl$(TCL_VERSION)$(SUFX).lib
+# When building extensions, may be linking against Tcl that does not add
+# "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility.
+!if !exist("$(TCLIMPLIB)")
+TCLIMPLIB = $(_TCLDIR)\lib\tcl$(TCL_VERSION)$(SUFX:t=).lib
!endif
-!if [nmakehlp -f $(CHECKS) "64bit"] && [nmakehlp -c -Wp64]
-!message *** Doing 64bit portability warnings
-WARNINGS = $(WARNINGS) -Wp64
+TCL_LIBRARY = $(_TCLDIR)\lib
+TCLREGLIB = $(_TCLDIR)\lib\tclreg13$(SUFX:t=).lib
+TCLDDELIB = $(_TCLDIR)\lib\tcldde14$(SUFX:t=).lib
+TCLTOOLSDIR = \must\have\tcl\sources\to\build\this\target
+TCL_INCLUDES = -I"$(_TCLDIR)\include"
+
+!else # Building against Tcl sources
+
+TCLSH = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)$(SUFX).exe
+!if !exist($(TCLSH)) && $(TCL_THREADS)
+TCLSH = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)t$(SUFX).exe
+!endif
+!if !exist($(TCLSH))
+TCLSH = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)$(SUFX:t=).exe
!endif
+TCLSTUBLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub$(TCL_VERSION).lib
+TCLIMPLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)$(SUFX).lib
+# When building extensions, may be linking against Tcl that does not add
+# "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility.
+!if !exist("$(TCLIMPLIB)")
+TCLIMPLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)$(SUFX:t=).lib
!endif
+TCL_LIBRARY = $(_TCLDIR)\library
+TCLREGLIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tclreg13$(SUFX:t=).lib
+TCLDDELIB = $(_TCLDIR)\win\$(BUILDDIRTOP)\tcldde14$(SUFX:t=).lib
+TCLTOOLSDIR = $(_TCLDIR)\tools
+TCL_INCLUDES = -I"$(_TCLDIR)\generic" -I"$(_TCLDIR)\win"
-!if $(PGO) > 1
-!if [nmakehlp -l -ltcg:pgoptimize $(LINKER_TESTFLAGS)]
-LINKERFLAGS = $(LINKERFLAGS:-ltcg=) -ltcg:pgoptimize
+!endif # TCLINSTALL
+
+tcllibs = "$(TCLSTUBLIB)" "$(TCLIMPLIB)"
+
+!endif # $(DOING_TCL)
+
+# We need a tclsh that will run on the host machine as part of the build.
+# IX86 runs on all architectures.
+!ifndef TCLSH_NATIVE
+!if "$(MACHINE)" == "IX86" || "$(MACHINE)" == "$(NATIVE_ARCH)"
+TCLSH_NATIVE = $(TCLSH)
!else
-MSG=^
-This compiler does not support profile guided optimization.
-!error $(MSG)
+!error You must explicitly set TCLSH_NATIVE for cross-compilation
!endif
-!elseif $(PGO) > 0
-!if [nmakehlp -l -ltcg:pginstrument $(LINKER_TESTFLAGS)]
-LINKERFLAGS = $(LINKERFLAGS:-ltcg=) -ltcg:pginstrument
-!else
-MSG=^
-This compiler does not support profile guided optimization.
-!error $(MSG)
!endif
+
+# Do the same for Tk and Tk extensions that require the Tk libraries
+!if $(DOING_TK) || $(NEED_TK)
+WISHNAMEPREFIX = wish
+WISHNAME = $(WISHNAMEPREFIX)$(TK_VERSION)$(SUFX).exe
+TKLIBNAME = $(PROJECT)$(TK_VERSION)$(SUFX).$(EXT)
+TKSTUBLIBNAME = tkstub$(TK_VERSION).lib
+TKIMPLIBNAME = tk$(TK_VERSION)$(SUFX).lib
+
+!if $(DOING_TK)
+WISH = $(OUT_DIR)\$(WISHNAME)
+TKSTUBLIB = $(OUT_DIR)\$(TKSTUBLIBNAME)
+TKIMPLIB = $(OUT_DIR)\$(TKIMPLIBNAME)
+TKLIB = $(OUT_DIR)\$(TKLIBNAME)
+TK_INCLUDES = -I"$(WINDIR)" -I"$(GENERICDIR)"
+
+!else # effectively NEED_TK
+
+!if $(TKINSTALL) # Building against installed Tk
+WISH = $(_TKDIR)\bin\$(WISHNAME)
+TKSTUBLIB = $(_TKDIR)\lib\$(TKSTUBLIBNAME)
+TKIMPLIB = $(_TKDIR)\lib\$(TKIMPLIBNAME)
+# When building extensions, may be linking against Tk that does not add
+# "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility.
+!if !exist("$(TKIMPLIB)")
+TKIMPLIBNAME = tk$(TK_VERSION)$(SUFX:t=).lib
+TKIMPLIB = $(_TKDIR)\lib\$(TKIMPLIBNAME)
+!endif
+TK_INCLUDES = -I"$(_TKDIR)\include"
+!else # Building against Tk sources
+WISH = $(_TKDIR)\win\$(BUILDDIRTOP)\$(WISHNAME)
+TKSTUBLIB = $(_TKDIR)\win\$(BUILDDIRTOP)\$(TKSTUBLIBNAME)
+TKIMPLIB = $(_TKDIR)\win\$(BUILDDIRTOP)\$(TKIMPLIBNAME)
+# When building extensions, may be linking against Tk that does not add
+# "t" suffix (e.g. 8.5 or 8.7). If lib not found check for that possibility.
+!if !exist("$(TKIMPLIB)")
+TKIMPLIBNAME = tk$(TK_VERSION)$(SUFX:t=).lib
+TKIMPLIB = $(_TKDIR)\win\$(BUILDDIRTOP)\$(TKIMPLIBNAME)
!endif
+TK_INCLUDES = -I"$(_TKDIR)\generic" -I"$(_TKDIR)\win" -I"$(_TKDIR)\xlib"
+!endif # TKINSTALL
+tklibs = "$(TKSTUBLIB)" "$(TKIMPLIB)"
-#----------------------------------------------------------
-# Set our defines now armed with our options.
-#----------------------------------------------------------
+!endif # $(DOING_TK)
+!endif # $(DOING_TK) || $(NEED_TK)
+
+# Various output paths
+PRJIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib
+PRJLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT)
+PRJLIB = $(OUT_DIR)\$(PRJLIBNAME)
+
+PRJSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib
+PRJSTUBLIB = $(OUT_DIR)\$(PRJSTUBLIBNAME)
+
+# If extension parent makefile has not defined a resource definition file,
+# we will generate one from standard template.
+!if !$(DOING_TCL) && !$(DOING_TK) && !$(STATIC_BUILD)
+!ifdef RCFILE
+RESFILE = $(TMP_DIR)\$(RCFILE:.rc=.res)
+!else
+RESFILE = $(TMP_DIR)\$(PROJECT).res
+!endif
+!endif
+
+###################################################################
+# 11. Construct the paths for the installation directories
+# The following macros get defined in this section:
+# LIB_INSTALL_DIR - where libraries should be installed
+# BIN_INSTALL_DIR - where the executables should be installed
+# DOC_INSTALL_DIR - where documentation should be installed
+# SCRIPT_INSTALL_DIR - where scripts should be installed
+# INCLUDE_INSTALL_DIR - where C include files should be installed
+# DEMO_INSTALL_DIR - where demos should be installed
+# PRJ_INSTALL_DIR - where package will be installed (not set for Tcl and Tk)
+
+!if $(DOING_TCL) || $(DOING_TK)
+LIB_INSTALL_DIR = $(_INSTALLDIR)\lib
+BIN_INSTALL_DIR = $(_INSTALLDIR)\bin
+DOC_INSTALL_DIR = $(_INSTALLDIR)\doc
+!if $(DOING_TCL)
+SCRIPT_INSTALL_DIR = $(_INSTALLDIR)\lib\$(PROJECT)$(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION)
+!else # DOING_TK
+SCRIPT_INSTALL_DIR = $(_INSTALLDIR)\lib\$(PROJECT)$(TK_MAJOR_VERSION).$(TK_MINOR_VERSION)
+!endif
+DEMO_INSTALL_DIR = $(SCRIPT_INSTALL_DIR)\demos
+INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\include
+
+!else # extension other than Tk
+
+PRJ_INSTALL_DIR = $(_INSTALLDIR)\$(PROJECT)$(DOTVERSION)
+LIB_INSTALL_DIR = $(PRJ_INSTALL_DIR)
+BIN_INSTALL_DIR = $(PRJ_INSTALL_DIR)
+DOC_INSTALL_DIR = $(PRJ_INSTALL_DIR)
+SCRIPT_INSTALL_DIR = $(PRJ_INSTALL_DIR)
+DEMO_INSTALL_DIR = $(PRJ_INSTALL_DIR)\demos
+INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\..\include
+
+!endif
+
+###################################################################
+# 12. Set up actual options to be passed to the compiler and linker
+# Now we have all the information we need, set up the actual flags and
+# options that we will pass to the compiler and linker. The main
+# makefile should use these in combination with whatever other flags
+# and switches are specific to it.
+# The following macros are defined, names are for historical compatibility:
+# OPTDEFINES - /Dxxx C macro flags based on user-specified OPTS
+# COMPILERFLAGS - /Dxxx C macro flags independent of any configuration opttions
+# crt - Compiler switch that selects the appropriate C runtime
+# cdebug - Compiler switches related to debug AND optimizations
+# cwarn - Compiler switches that set warning levels
+# cflags - complete compiler switches (subsumes cdebug and cwarn)
+# ldebug - Linker switches controlling debug information and optimization
+# lflags - complete linker switches (subsumes ldebug) except subsystem type
+# dlllflags - complete linker switches to build DLLs (subsumes lflags)
+# conlflags - complete linker switches for console program (subsumes lflags)
+# guilflags - complete linker switches for GUI program (subsumes lflags)
+# baselibs - minimum Windows libraries required. Parent makefile can
+# define PRJ_LIBS before including rules.rc if additional libs are needed
OPTDEFINES = -DTCL_CFGVAL_ENCODING=$(CFG_ENCODING) -DSTDC_HEADERS
@@ -472,6 +1277,17 @@ OPTDEFINES = $(OPTDEFINES) -DSTATIC_BUILD OPTDEFINES = $(OPTDEFINES) -DTCL_NO_DEPRECATED
!endif
+!if $(USE_STUBS)
+# Note we do not define USE_TCL_STUBS even when building tk since some
+# test targets in tk do not use stubs
+!if ! $(DOING_TCL)
+USE_STUBS_DEFS = -DUSE_TCL_STUBS -DUSE_TCLOO_STUBS
+!if $(NEED_TK)
+USE_STUBS_DEFS = $(USE_STUBS_DEFS) -DUSE_TK_STUBS
+!endif
+!endif
+!endif # USE_STUBS
+
!if !$(DEBUG)
OPTDEFINES = $(OPTDEFINES) -DNDEBUG
!if $(OPTIMIZING)
@@ -481,223 +1297,456 @@ OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_OPTIMIZED !if $(PROFILE)
OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_PROFILED
!endif
-!if "$(MACHINE)" == "IA64" || "$(MACHINE)" == "AMD64"
+!if "$(MACHINE)" == "AMD64"
OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_DO64BIT
!endif
!if $(VCVERSION) < 1300
OPTDEFINES = $(OPTDEFINES) -DNO_STRTOI64
!endif
-#----------------------------------------------------------
-# Locate the Tcl headers to build against
-#----------------------------------------------------------
-
-!if "$(PROJECT)" == "tcl"
-
-_TCL_H = ..\generic\tcl.h
+# _ATL_XP_TARGETING - Newer SDK's need this to build for XP
+COMPILERFLAGS = /D_ATL_XP_TARGETING
+# Following is primarily for the benefit of extensions. Tcl 8.5 builds
+# Tcl without /DUNICODE, while 8.6 builds with it defined. When building
+# an extension, it is advisable (but not mandated) to use the same Windows
+# API as the Tcl build. This is accordingly defaulted below. A particular
+# extension can override this by pre-definining USE_WIDECHAR_API.
+!ifndef USE_WIDECHAR_API
+!if $(TCL_VERSION) > 85
+USE_WIDECHAR_API = 1
!else
+USE_WIDECHAR_API = 0
+!endif
+!endif
-# If INSTALLDIR set to tcl root dir then reset to the lib dir.
-!if exist("$(_INSTALLDIR)\include\tcl.h")
-_INSTALLDIR=$(_INSTALLDIR)\lib
+!if $(USE_WIDECHAR_API)
+COMPILERFLAGS = $(COMPILERFLAGS) /DUNICODE /D_UNICODE
!endif
-!if !defined(TCLDIR)
-!if exist("$(_INSTALLDIR)\..\include\tcl.h")
-TCLINSTALL = 1
-_TCLDIR = $(_INSTALLDIR)\..
-_TCL_H = $(_INSTALLDIR)\..\include\tcl.h
-TCLDIR = $(_INSTALLDIR)\..
+# Like the TEA system only set this non empty for non-Tk extensions
+# Note: some extensions use PACKAGE_NAME and others use PACKAGE_TCLNAME
+# so we pass both
+!if !$(DOING_TCL) && !$(DOING_TK)
+PKGNAMEFLAGS = -DPACKAGE_NAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \
+ -DPACKAGE_TCLNAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \
+ -DPACKAGE_VERSION="\"$(DOTVERSION)\"" \
+ -DMODULE_SCOPE=extern
+!endif
+
+# crt picks the C run time based on selected OPTS
+!if $(MSVCRT)
+!if $(DEBUG) && !$(UNCHECKED)
+crt = -MDd
!else
-MSG=^
-Failed to find tcl.h. Set the TCLDIR macro.
-!error $(MSG)
+crt = -MD
!endif
!else
-_TCLDIR = $(TCLDIR:/=\)
-!if exist("$(_TCLDIR)\include\tcl.h")
-TCLINSTALL = 1
-_TCL_H = $(_TCLDIR)\include\tcl.h
-!elseif exist("$(_TCLDIR)\generic\tcl.h")
-TCLINSTALL = 0
-_TCL_H = $(_TCLDIR)\generic\tcl.h
+!if $(DEBUG) && !$(UNCHECKED)
+crt = -MTd
!else
-MSG =^
-Failed to find tcl.h. The TCLDIR macro does not appear correct.
-!error $(MSG)
-!endif
+crt = -MT
!endif
!endif
-#--------------------------------------------------------------
-# Extract various version numbers from tcl headers
-# The generated file is then included in the makefile.
-#--------------------------------------------------------------
+# cdebug includes compiler options for debugging as well as optimization.
+!if $(DEBUG)
-!if [echo REM = This file is generated from rules.vc > versions.vc]
-!endif
-!if [echo TCL_MAJOR_VERSION = \>> versions.vc] \
- && [nmakehlp -V "$(_TCL_H)" TCL_MAJOR_VERSION >> versions.vc]
+# In debugging mode, optimizations need to be disabled
+cdebug = -Zi -Od $(DEBUGFLAGS)
+
+!else
+
+cdebug = $(OPTIMIZATIONS)
+!if $(SYMBOLS)
+cdebug = $(cdebug) -Zi
!endif
-!if [echo TCL_MINOR_VERSION = \>> versions.vc] \
- && [nmakehlp -V "$(_TCL_H)" TCL_MINOR_VERSION >> versions.vc]
+
+!endif # $(DEBUG)
+
+# cwarn includes default warning levels.
+cwarn = $(WARNINGS)
+
+!if "$(MACHINE)" == "AMD64"
+# Disable pointer<->int warnings related to cast between different sizes
+# There are a gadzillion of these due to use of ClientData and
+# clutter up compiler
+# output increasing chance of a real warning getting lost. So disable them.
+# Eventually some day, Tcl will be 64-bit clean.
+cwarn = $(cwarn) -wd4311 -wd4312
!endif
-!if [echo TCL_PATCH_LEVEL = \>> versions.vc] \
- && [nmakehlp -V "$(_TCL_H)" TCL_PATCH_LEVEL >> versions.vc]
+
+### Common compiler options that are architecture specific
+!if "$(MACHINE)" == "ARM"
+carch = -D_ARM_WINAPI_PARTITION_DESKTOP_SDK_AVAILABLE
+!else
+carch =
!endif
-# If building the tcl core then we need additional package versions
-!if "$(PROJECT)" == "tcl"
-!if [echo PKG_HTTP_VER = \>> versions.vc] \
- && [nmakehlp -V ..\library\http\pkgIndex.tcl http >> versions.vc]
+!if $(DEBUG)
+# Turn warnings into errors
+cwarn = $(cwarn) -WX
!endif
-!if [echo PKG_TCLTEST_VER = \>> versions.vc] \
- && [nmakehlp -V ..\library\tcltest\pkgIndex.tcl tcltest >> versions.vc]
+
+INCLUDES = $(TCL_INCLUDES) $(TK_INCLUDES) $(PRJ_INCLUDES)
+!if !$(DOING_TCL) && !$(DOING_TK)
+INCLUDES = $(INCLUDES) -I"$(GENERICDIR)" -I"$(WINDIR)" -I"$(COMPATDIR)"
!endif
-!if [echo PKG_MSGCAT_VER = \>> versions.vc] \
- && [nmakehlp -V ..\library\msgcat\pkgIndex.tcl msgcat >> versions.vc]
+
+# These flags are defined roughly in the order of the pre-reform
+# rules.vc/makefile.vc to help visually compare that the pre- and
+# post-reform build logs
+
+# cflags contains generic flags used for building practically all object files
+cflags = -nologo -c $(COMPILERFLAGS) $(carch) $(cwarn) -Fp$(TMP_DIR)^\ $(cdebug)
+
+# appcflags contains $(cflags) and flags for building the application
+# object files (e.g. tclsh, or wish) pkgcflags contains $(cflags) plus
+# flags used for building shared object files The two differ in the
+# BUILD_$(PROJECT) macro which should be defined only for the shared
+# library *implementation* and not for its caller interface
+
+appcflags = $(cflags) $(crt) $(INCLUDES) $(TCL_DEFINES) $(PRJ_DEFINES) $(OPTDEFINES) $(USE_STUBS_DEFS)
+appcflags_nostubs = $(cflags) $(crt) $(INCLUDES) $(TCL_DEFINES) $(PRJ_DEFINES) $(OPTDEFINES)
+pkgcflags = $(appcflags) $(PKGNAMEFLAGS) -DBUILD_$(PROJECT)
+pkgcflags_nostubs = $(appcflags_nostubs) $(PKGNAMEFLAGS) -DBUILD_$(PROJECT)
+
+# stubscflags contains $(cflags) plus flags used for building a stubs
+# library for the package. Note: -DSTATIC_BUILD is defined in
+# $(OPTDEFINES) only if the OPTS configuration indicates a static
+# library. However the stubs library is ALWAYS static hence included
+# here irrespective of the OPTS setting.
+#
+# TBD - tclvfs has a comment that stubs libs should not be compiled with -GL
+# without stating why. Tcl itself compiled stubs libs with this flag.
+# so we do not remove it from cflags. -GL may prevent extensions
+# compiled with one VC version to fail to link against stubs library
+# compiled with another VC version. Check for this and fix accordingly.
+stubscflags = $(cflags) $(PKGNAMEFLAGS) $(PRJ_DEFINES) $(OPTDEFINES) -Zl -DSTATIC_BUILD $(INCLUDES)
+
+# Link flags
+
+!if $(DEBUG)
+ldebug = -debug -debugtype:cv
+!else
+ldebug = -release -opt:ref -opt:icf,3
+!if $(SYMBOLS)
+ldebug = $(ldebug) -debug -debugtype:cv
!endif
-!if [echo PKG_PLATFORM_VER = \>> versions.vc] \
- && [nmakehlp -V ..\library\platform\pkgIndex.tcl "platform " >> versions.vc]
!endif
-!if [echo PKG_SHELL_VER = \>> versions.vc] \
- && [nmakehlp -V ..\library\platform\pkgIndex.tcl "platform::shell" >> versions.vc]
+
+# Note: Profiling is currently only possible with the Visual Studio Enterprise
+!if $(PROFILE)
+ldebug= $(ldebug) -profile
!endif
-!if [echo PKG_DDE_VER = \>> versions.vc] \
- && [nmakehlp -V ..\library\dde\pkgIndex.tcl "dde " >> versions.vc]
+
+### Declarations common to all linker versions
+lflags = -nologo -machine:$(MACHINE) $(LINKERFLAGS) $(ldebug)
+
+!if $(MSVCRT) && !($(DEBUG) && !$(UNCHECKED)) && $(VCVERSION) >= 1900
+lflags = $(lflags) -nodefaultlib:libucrt.lib
!endif
-!if [echo PKG_REG_VER =\>> versions.vc] \
- && [nmakehlp -V ..\library\reg\pkgIndex.tcl registry >> versions.vc]
+
+# Old linkers (Visual C++ 6 in particular) will link for fast loading
+# on Win98. Since we do not support Win98 any more, we specify nowin98
+# as recommended for NT and later. However, this is only required by
+# IX86 on older compilers and only needed if we are not doing a static build.
+
+!if "$(MACHINE)" == "IX86" && !$(STATIC_BUILD)
+!if [nmakehlp -l -opt:nowin98 $(LINKER_TESTFLAGS)]
+# Align sections for PE size savings.
+lflags = $(lflags) -opt:nowin98
!endif
!endif
-!include versions.vc
+dlllflags = $(lflags) -dll
+conlflags = $(lflags) -subsystem:console
+guilflags = $(lflags) -subsystem:windows
-#--------------------------------------------------------------
-# Setup tcl version dependent stuff headers
-#--------------------------------------------------------------
+# Libraries that are required for every image.
+# Extensions should define any additional libraries with $(PRJ_LIBS)
+winlibs = kernel32.lib advapi32.lib
-!if "$(PROJECT)" != "tcl"
-
-TCL_VERSION = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION)
+!if $(NEED_TK)
+winlibs = $(winlibs) gdi32.lib user32.lib uxtheme.lib
+!endif
-!if $(TCLINSTALL)
-TCLSH = "$(_TCLDIR)\bin\tclsh$(TCL_VERSION)$(SUFX).exe"
-!if !exist($(TCLSH)) && $(TCL_THREADS)
-TCLSH = "$(_TCLDIR)\bin\tclsh$(TCL_VERSION)t$(SUFX).exe"
+# Avoid 'unresolved external symbol __security_cookie' errors.
+# c.f. http://support.microsoft.com/?id=894573
+!if "$(MACHINE)" == "AMD64"
+!if $(VCVERSION) > 1399 && $(VCVERSION) < 1500
+winlibs = $(winlibs) bufferoverflowU.lib
!endif
-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"
-COFFBASE = \must\have\tcl\sources\to\build\this\target
-TCLTOOLSDIR = \must\have\tcl\sources\to\build\this\target
-TCL_INCLUDES = -I"$(_TCLDIR)\include"
-!else
-TCLSH = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)$(SUFX).exe"
-!if !exist($(TCLSH)) && $(TCL_THREADS)
-TCLSH = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclsh$(TCL_VERSION)t$(SUFX).exe"
-!endif
-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"
-COFFBASE = "$(_TCLDIR)\win\coffbase.txt"
-TCLTOOLSDIR = $(_TCLDIR)\tools
-TCL_INCLUDES = -I"$(_TCLDIR)\generic" -I"$(_TCLDIR)\win"
!endif
+baselibs = $(winlibs) $(PRJ_LIBS)
+
+!if $(MSVCRT) && !($(DEBUG) && !$(UNCHECKED)) && $(VCVERSION) >= 1900
+baselibs = $(baselibs) ucrt.lib
!endif
-#-------------------------------------------------------------------------
-# Locate the Tk headers to build against
-#-------------------------------------------------------------------------
+################################################################
+# 13. Define standard commands, common make targets and implicit rules
-!if "$(PROJECT)" == "tk"
-_TK_H = ..\generic\tk.h
-_INSTALLDIR = $(_INSTALLDIR)\..
-!endif
+CCPKGCMD = $(cc32) $(pkgcflags) -Fo$(TMP_DIR)^\
+CCAPPCMD = $(cc32) $(appcflags) -Fo$(TMP_DIR)^\
+CCSTUBSCMD = $(cc32) $(stubscflags) -Fo$(TMP_DIR)^\
-!ifdef PROJECT_REQUIRES_TK
-!if !defined(TKDIR)
-!if exist("$(_INSTALLDIR)\..\include\tk.h")
-TKINSTALL = 1
-_TKDIR = $(_INSTALLDIR)\..
-_TK_H = $(_TKDIR)\include\tk.h
-TKDIR = $(_TKDIR)
-!elseif exist("$(_TCLDIR)\include\tk.h")
-TKINSTALL = 1
-_TKDIR = $(_TCLDIR)
-_TK_H = $(_TKDIR)\include\tk.h
-TKDIR = $(_TKDIR)
+LIBCMD = $(lib32) -nologo $(LINKERFLAGS) -out:$@
+DLLCMD = $(link32) $(dlllflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs)
+
+CONEXECMD = $(link32) $(conlflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs)
+GUIEXECMD = $(link32) $(guilflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs)
+RESCMD = $(rc32) -fo $@ -r -i "$(GENERICDIR)" -i "$(TMP_DIR)" \
+ $(TCL_INCLUDES) \
+ -DDEBUG=$(DEBUG) -d UNCHECKED=$(UNCHECKED) \
+ -DCOMMAVERSION=$(DOTVERSION:.=,),0 \
+ -DDOTVERSION=\"$(DOTVERSION)\" \
+ -DVERSION=\"$(VERSION)\" \
+ -DSUFX=\"$(SUFX)\" \
+ -DPROJECT=\"$(PROJECT)\" \
+ -DPRJLIBNAME=\"$(PRJLIBNAME)\"
+
+!ifndef DEFAULT_BUILD_TARGET
+DEFAULT_BUILD_TARGET = $(PROJECT)
!endif
+
+default-target: $(DEFAULT_BUILD_TARGET)
+
+default-pkgindex:
+ @echo package ifneeded $(PRJ_PACKAGE_TCLNAME) $(DOTVERSION) \
+ [list load [file join $$dir $(PRJLIBNAME)]] > $(OUT_DIR)\pkgIndex.tcl
+
+default-pkgindex-tea:
+ @if exist $(ROOT)\pkgIndex.tcl.in nmakehlp -s << $(ROOT)\pkgIndex.tcl.in > $(OUT_DIR)\pkgIndex.tcl
+@PACKAGE_VERSION@ $(DOTVERSION)
+@PACKAGE_NAME@ $(PRJ_PACKAGE_TCLNAME)
+@PACKAGE_TCLNAME@ $(PRJ_PACKAGE_TCLNAME)
+@PKG_LIB_FILE@ $(PRJLIBNAME)
+<<
+
+
+default-install: default-install-binaries default-install-libraries
+
+default-install-binaries: $(PRJLIB)
+ @echo Installing binaries to '$(SCRIPT_INSTALL_DIR)'
+ @if not exist "$(SCRIPT_INSTALL_DIR)" mkdir "$(SCRIPT_INSTALL_DIR)"
+ @$(CPY) $(PRJLIB) "$(SCRIPT_INSTALL_DIR)" >NUL
+
+default-install-libraries: $(OUT_DIR)\pkgIndex.tcl
+ @echo Installing libraries to '$(SCRIPT_INSTALL_DIR)'
+ @if exist $(LIBDIR) $(CPY) $(LIBDIR)\*.tcl "$(SCRIPT_INSTALL_DIR)"
+ @echo Installing package index in '$(SCRIPT_INSTALL_DIR)'
+ @$(CPY) $(OUT_DIR)\pkgIndex.tcl $(SCRIPT_INSTALL_DIR)
+
+default-install-stubs:
+ @echo Installing stubs library to '$(SCRIPT_INSTALL_DIR)'
+ @if not exist "$(SCRIPT_INSTALL_DIR)" mkdir "$(SCRIPT_INSTALL_DIR)"
+ @$(CPY) $(PRJSTUBLIB) "$(SCRIPT_INSTALL_DIR)" >NUL
+
+default-install-docs-html:
+ @echo Installing documentation files to '$(DOC_INSTALL_DIR)'
+ @if not exist "$(DOC_INSTALL_DIR)" mkdir "$(DOC_INSTALL_DIR)"
+ @if exist $(DOCDIR) for %f in ("$(DOCDIR)\*.html" "$(DOCDIR)\*.css" "$(DOCDIR)\*.png") do @$(COPY) %f "$(DOC_INSTALL_DIR)"
+
+default-install-docs-n:
+ @echo Installing documentation files to '$(DOC_INSTALL_DIR)'
+ @if not exist "$(DOC_INSTALL_DIR)" mkdir "$(DOC_INSTALL_DIR)"
+ @if exist $(DOCDIR) for %f in ("$(DOCDIR)\*.n") do @$(COPY) %f "$(DOC_INSTALL_DIR)"
+
+default-install-demos:
+ @echo Installing demos to '$(DEMO_INSTALL_DIR)'
+ @if not exist "$(DEMO_INSTALL_DIR)" mkdir "$(DEMO_INSTALL_DIR)"
+ @if exist $(DEMODIR) $(CPYDIR) "$(DEMODIR)" "$(DEMO_INSTALL_DIR)"
+
+default-clean:
+ @echo Cleaning $(TMP_DIR)\* ...
+ @if exist $(TMP_DIR)\nul $(RMDIR) $(TMP_DIR)
+ @echo Cleaning $(WINDIR)\nmakehlp.obj, nmakehlp.exe ...
+ @if exist $(WINDIR)\nmakehlp.obj del $(WINDIR)\nmakehlp.obj
+ @if exist $(WINDIR)\nmakehlp.exe del $(WINDIR)\nmakehlp.exe
+ @if exist $(WINDIR)\nmakehlp.out del $(WINDIR)\nmakehlp.out
+ @echo Cleaning $(WINDIR)\nmhlp-out.txt ...
+ @if exist $(WINDIR)\nmhlp-out.txt del $(WINDIR)\nmhlp-out.txt
+ @echo Cleaning $(WINDIR)\_junk.pch ...
+ @if exist $(WINDIR)\_junk.pch del $(WINDIR)\_junk.pch
+ @echo Cleaning $(WINDIR)\vercl.x, vercl.i ...
+ @if exist $(WINDIR)\vercl.x del $(WINDIR)\vercl.x
+ @if exist $(WINDIR)\vercl.i del $(WINDIR)\vercl.i
+ @echo Cleaning $(WINDIR)\versions.vc, version.vc ...
+ @if exist $(WINDIR)\versions.vc del $(WINDIR)\versions.vc
+ @if exist $(WINDIR)\version.vc del $(WINDIR)\version.vc
+
+default-hose: default-clean
+ @echo Hosing $(OUT_DIR)\* ...
+ @if exist $(OUT_DIR)\nul $(RMDIR) $(OUT_DIR)
+
+# Only for backward compatibility
+default-distclean: default-hose
+
+default-setup:
+ @if not exist $(OUT_DIR)\nul mkdir $(OUT_DIR)
+ @if not exist $(TMP_DIR)\nul mkdir $(TMP_DIR)
+
+!if "$(TESTPAT)" != ""
+TESTFLAGS = $(TESTFLAGS) -file $(TESTPAT)
+!endif
+
+default-test: default-setup $(PROJECT)
+ @set TCLLIBPATH=$(OUT_DIR:\=/)
+ @if exist $(LIBDIR) for %f in ("$(LIBDIR)\*.tcl") do @$(COPY) %f "$(OUT_DIR)"
+ cd "$(TESTDIR)" && $(DEBUGGER) $(TCLSH) all.tcl $(TESTFLAGS)
+
+default-shell: default-setup $(PROJECT)
+ @set TCLLIBPATH=$(OUT_DIR:\=/)
+ @if exist $(LIBDIR) for %f in ("$(LIBDIR)\*.tcl") do @$(COPY) %f "$(OUT_DIR)"
+ $(DEBUGGER) $(TCLSH)
+
+# Generation of Windows version resource
+!ifdef RCFILE
+
+# Note: don't use $** in below rule because there may be other dependencies
+# and only the "master" rc must be passed to the resource compiler
+$(TMP_DIR)\$(PROJECT).res: $(RCDIR)\$(PROJECT).rc
+ $(RESCMD) $(RCDIR)\$(PROJECT).rc
+
!else
-_TKDIR = $(TKDIR:/=\)
-!if exist("$(_TKDIR)\include\tk.h")
-TKINSTALL = 1
-_TK_H = $(_TKDIR)\include\tk.h
-!elseif exist("$(_TKDIR)\generic\tk.h")
-TKINSTALL = 0
-_TK_H = $(_TKDIR)\generic\tk.h
-!else
-MSG =^
-Failed to find tk.h. The TKDIR macro does not appear correct.
-!error $(MSG)
-!endif
-!endif
+
+# If parent makefile has not defined a resource definition file,
+# we will generate one from standard template.
+$(TMP_DIR)\$(PROJECT).res: $(TMP_DIR)\$(PROJECT).rc
+
+$(TMP_DIR)\$(PROJECT).rc:
+ @$(COPY) << $(TMP_DIR)\$(PROJECT).rc
+#include <winver.h>
+
+VS_VERSION_INFO VERSIONINFO
+ FILEVERSION COMMAVERSION
+ PRODUCTVERSION COMMAVERSION
+ FILEFLAGSMASK 0x3fL
+#ifdef DEBUG
+ FILEFLAGS VS_FF_DEBUG
+#else
+ FILEFLAGS 0x0L
+#endif
+ FILEOS VOS_NT_WINDOWS32
+ FILETYPE VFT_DLL
+ FILESUBTYPE 0x0L
+BEGIN
+ BLOCK "StringFileInfo"
+ BEGIN
+ BLOCK "040904b0"
+ BEGIN
+ VALUE "FileDescription", "Tcl extension " PROJECT
+ VALUE "OriginalFilename", PRJLIBNAME
+ VALUE "FileVersion", DOTVERSION
+ VALUE "ProductName", "Package " PROJECT " for Tcl"
+ VALUE "ProductVersion", DOTVERSION
+ END
+ END
+ BLOCK "VarFileInfo"
+ BEGIN
+ VALUE "Translation", 0x409, 1200
+ END
+END
+
+<<
+
+!endif # ifdef RCFILE
+
+!ifndef DISABLE_IMPLICIT_RULES
+DISABLE_IMPLICIT_RULES = 0
!endif
-#-------------------------------------------------------------------------
-# Extract Tk version numbers
-#-------------------------------------------------------------------------
+!if !$(DISABLE_IMPLICIT_RULES)
+# Implicit rule definitions - only for building library objects. For stubs and
+# main application, the master makefile should define explicit rules.
-!if defined(PROJECT_REQUIRES_TK) || "$(PROJECT)" == "tk"
+{$(ROOT)}.c{$(TMP_DIR)}.obj::
+ $(CCPKGCMD) @<<
+$<
+<<
+
+{$(WINDIR)}.c{$(TMP_DIR)}.obj::
+ $(CCPKGCMD) @<<
+$<
+<<
+
+{$(GENERICDIR)}.c{$(TMP_DIR)}.obj::
+ $(CCPKGCMD) @<<
+$<
+<<
+
+{$(COMPATDIR)}.c{$(TMP_DIR)}.obj::
+ $(CCPKGCMD) @<<
+$<
+<<
+
+{$(RCDIR)}.rc{$(TMP_DIR)}.res:
+ $(RESCMD) $<
+
+{$(WINDIR)}.rc{$(TMP_DIR)}.res:
+ $(RESCMD) $<
+
+{$(TMP_DIR)}.rc{$(TMP_DIR)}.res:
+ $(RESCMD) $<
+
+.SUFFIXES:
+.SUFFIXES:.c .rc
-!if [echo TK_MAJOR_VERSION = \>> versions.vc] \
- && [nmakehlp -V $(_TK_H) TK_MAJOR_VERSION >> versions.vc]
!endif
-!if [echo TK_MINOR_VERSION = \>> versions.vc] \
- && [nmakehlp -V $(_TK_H) TK_MINOR_VERSION >> versions.vc]
+
+################################################################
+# 14. Sanity check selected options against Tcl build options
+# When building an extension, certain configuration options should
+# match the ones used when Tcl was built. Here we check and
+# warn on a mismatch.
+!if ! $(DOING_TCL)
+
+!if $(TCLINSTALL) # Building against an installed Tcl
+!if exist("$(_TCLDIR)\lib\nmake\tcl.nmake")
+TCLNMAKECONFIG = "$(_TCLDIR)\lib\nmake\tcl.nmake"
!endif
-!if [echo TK_PATCH_LEVEL = \>> versions.vc] \
- && [nmakehlp -V $(_TK_H) TK_PATCH_LEVEL >> versions.vc]
+!else # ! $(TCLINSTALL) - building against Tcl source
+!if exist("$(OUT_DIR)\tcl.nmake")
+TCLNMAKECONFIG = "$(OUT_DIR)\tcl.nmake"
!endif
+!endif # TCLINSTALL
-!include versions.vc
-
-TK_DOTVERSION = $(TK_MAJOR_VERSION).$(TK_MINOR_VERSION)
-TK_VERSION = $(TK_MAJOR_VERSION)$(TK_MINOR_VERSION)
+!if $(CONFIG_CHECK)
+!ifdef TCLNMAKECONFIG
+!include $(TCLNMAKECONFIG)
-!if "$(PROJECT)" != "tk"
-!if $(TKINSTALL)
-WISH = "$(_TKDIR)\bin\wish$(TK_VERSION)$(SUFX).exe"
-TKSTUBLIB = "$(_TKDIR)\lib\tkstub$(TK_VERSION).lib"
-TKIMPLIB = "$(_TKDIR)\lib\tk$(TK_VERSION)$(SUFX).lib"
-TK_INCLUDES = -I"$(_TKDIR)\include"
-!else
-WISH = "$(_TKDIR)\win\$(BUILDDIRTOP)\wish$(TCL_VERSION)$(SUFX).exe"
-TKSTUBLIB = "$(_TKDIR)\win\$(BUILDDIRTOP)\tkstub$(TCL_VERSION).lib"
-TKIMPLIB = "$(_TKDIR)\win\$(BUILDDIRTOP)\tk$(TCL_VERSION)$(SUFX).lib"
-TK_INCLUDES = -I"$(_TKDIR)\generic" -I"$(_TKDIR)\win" -I"$(_TKDIR)\xlib"
+!if defined(CORE_MACHINE) && "$(CORE_MACHINE)" != "$(MACHINE)"
+!error ERROR: Build target ($(MACHINE)) does not match the Tcl library architecture ($(CORE_MACHINE)).
!endif
+!if defined(CORE_USE_THREAD_ALLOC) && $(CORE_USE_THREAD_ALLOC) != $(USE_THREAD_ALLOC)
+!message WARNING: Value of USE_THREAD_ALLOC ($(USE_THREAD_ALLOC)) does not match its Tcl core value ($(CORE_USE_THREAD_ALLOC)).
+!endif
+!if defined(CORE_DEBUG) && $(CORE_DEBUG) != $(DEBUG)
+!message WARNING: Value of DEBUG ($(DEBUG)) does not match its Tcl library configuration ($(DEBUG)).
!endif
-
!endif
+!endif # TCLNMAKECONFIG
+
+!endif # ! $(DOING_TCL)
+
+
#----------------------------------------------------------
# Display stats being used.
#----------------------------------------------------------
+!if !$(DOING_TCL)
+!message *** Building against Tcl at '$(_TCLDIR)'
+!endif
+!if !$(DOING_TK) && $(NEED_TK)
+!message *** Building against Tk at '$(_TKDIR)'
+!endif
!message *** Intermediate directory will be '$(TMP_DIR)'
!message *** Output directory will be '$(OUT_DIR)'
+!message *** Installation, if selected, will be in '$(_INSTALLDIR)'
!message *** Suffix for binaries will be '$(SUFX)'
-!message *** Optional defines are '$(OPTDEFINES)'
-!message *** Compiler version $(VCVER). Target machine is $(MACHINE)
-!message *** Host architecture is $(NATIVE_ARCH)
-!message *** Compiler options '$(COMPILERFLAGS) $(OPTIMIZATIONS) $(DEBUGFLAGS) $(WARNINGS)'
-!message *** Link options '$(LINKERFLAGS)'
+!message *** Compiler version $(VCVER). Target $(MACHINE), host $(NATIVE_ARCH).
-!endif
+!endif # ifdef _RULES_VC
diff --git a/win/stub16.c b/win/stub16.c deleted file mode 100644 index 70fc051..0000000 --- a/win/stub16.c +++ /dev/null @@ -1,195 +0,0 @@ -/* - * stub16.c - * - * A helper program used for running 16-bit DOS applications under - * Windows 95. - * - * Copyright (c) 1996 by Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#define STRICT - -#include <windows.h> -#include <stdio.h> - -static HANDLE CreateTempFile(void); - -/* - *--------------------------------------------------------------------------- - * - * main - * - * Entry point for the 32-bit console mode app used by Windows 95 to help - * run the 16-bit program specified on the command line. - * - * 1. EOF on a pipe that connects a detached 16-bit process and a 32-bit - * process is never seen. So, this process runs the 16-bit process - * _attached_, and then it is run detached from the calling 32-bit - * process. - * - * 2. If a 16-bit process blocks reading from or writing to a pipe, it - * never wakes up, and eventually brings the whole system down with it if - * you try to kill the process. This app simulates pipes. If any of the - * stdio handles is a pipe, this program accumulates information into - * temp files and forwards it to or from the DOS application as - * appropriate. This means that this program must receive EOF from a - * stdin pipe before it will actually start the DOS app, and the DOS app - * must finish generating stdout or stderr before the data will be sent - * to the next stage of the pipe. If the stdio handles are not pipes, no - * accumulation occurs and the data is passed straight through to and - * from the DOS application. - * - * Results: - * None. - * - * Side effects: - * The child process is created and this process waits for it to - * complete. - * - *--------------------------------------------------------------------------- - */ - -int -main(void) -{ - DWORD dwRead, dwWrite; - char *cmdLine; - HANDLE hStdInput, hStdOutput, hStdError; - HANDLE hFileInput, hFileOutput, hFileError; - STARTUPINFO si; - PROCESS_INFORMATION pi; - char buf[8192]; - DWORD result; - - hFileInput = INVALID_HANDLE_VALUE; - hFileOutput = INVALID_HANDLE_VALUE; - hFileError = INVALID_HANDLE_VALUE; - result = 1; - - /* - * Don't get command line from argc, argv, because the command line - * tokenizer will have stripped off all the escape sequences needed for - * quotes and backslashes, and then we'd have to put them all back in - * again. Get the raw command line and parse off what we want ourselves. - * The command line should be of the form: - * - * stub16.exe program arg1 arg2 ... - */ - - cmdLine = strchr(GetCommandLine(), ' '); - if (cmdLine == NULL) { - return 1; - } - cmdLine++; - - hStdInput = GetStdHandle(STD_INPUT_HANDLE); - hStdOutput = GetStdHandle(STD_OUTPUT_HANDLE); - hStdError = GetStdHandle(STD_ERROR_HANDLE); - - if (GetFileType(hStdInput) == FILE_TYPE_PIPE) { - hFileInput = CreateTempFile(); - if (hFileInput == INVALID_HANDLE_VALUE) { - goto cleanup; - } - while (ReadFile(hStdInput, buf, sizeof(buf), &dwRead, NULL) != FALSE) { - if (dwRead == 0) { - break; - } - if (WriteFile(hFileInput, buf, dwRead, &dwWrite, NULL) == FALSE) { - goto cleanup; - } - } - SetFilePointer(hFileInput, 0, 0, FILE_BEGIN); - SetStdHandle(STD_INPUT_HANDLE, hFileInput); - } - if (GetFileType(hStdOutput) == FILE_TYPE_PIPE) { - hFileOutput = CreateTempFile(); - if (hFileOutput == INVALID_HANDLE_VALUE) { - goto cleanup; - } - SetStdHandle(STD_OUTPUT_HANDLE, hFileOutput); - } - if (GetFileType(hStdError) == FILE_TYPE_PIPE) { - hFileError = CreateTempFile(); - if (hFileError == INVALID_HANDLE_VALUE) { - goto cleanup; - } - SetStdHandle(STD_ERROR_HANDLE, hFileError); - } - - ZeroMemory(&si, sizeof(si)); - si.cb = sizeof(si); - if (CreateProcess(NULL, cmdLine, NULL, NULL, TRUE, 0, NULL, NULL, &si, - &pi) == FALSE) { - goto cleanup; - } - - WaitForInputIdle(pi.hProcess, 5000); - WaitForSingleObject(pi.hProcess, INFINITE); - GetExitCodeProcess(pi.hProcess, &result); - CloseHandle(pi.hProcess); - CloseHandle(pi.hThread); - - if (hFileOutput != INVALID_HANDLE_VALUE) { - SetFilePointer(hFileOutput, 0, 0, FILE_BEGIN); - while (ReadFile(hFileOutput, buf, sizeof(buf), &dwRead, NULL) != FALSE) { - if (dwRead == 0) { - break; - } - if (WriteFile(hStdOutput, buf, dwRead, &dwWrite, NULL) == FALSE) { - break; - } - } - } - if (hFileError != INVALID_HANDLE_VALUE) { - SetFilePointer(hFileError, 0, 0, FILE_BEGIN); - while (ReadFile(hFileError, buf, sizeof(buf), &dwRead, NULL) != FALSE) { - if (dwRead == 0) { - break; - } - if (WriteFile(hStdError, buf, dwRead, &dwWrite, NULL) == FALSE) { - break; - } - } - } - - cleanup: - if (hFileInput != INVALID_HANDLE_VALUE) { - CloseHandle(hFileInput); - } - if (hFileOutput != INVALID_HANDLE_VALUE) { - CloseHandle(hFileOutput); - } - if (hFileError != INVALID_HANDLE_VALUE) { - CloseHandle(hFileError); - } - CloseHandle(hStdInput); - CloseHandle(hStdOutput); - CloseHandle(hStdError); - ExitProcess(result); - return 1; -} - -static HANDLE -CreateTempFile(void) -{ - char name[MAX_PATH]; - SECURITY_ATTRIBUTES sa; - - if (GetTempPath(sizeof(name), name) == 0) { - return INVALID_HANDLE_VALUE; - } - if (GetTempFileName(name, "tcl", 0, name) == 0) { - return INVALID_HANDLE_VALUE; - } - - sa.nLength = sizeof(sa); - sa.lpSecurityDescriptor = NULL; - sa.bInheritHandle = TRUE; - return CreateFile(name, GENERIC_READ | GENERIC_WRITE, 0, &sa, - CREATE_ALWAYS, FILE_ATTRIBUTE_TEMPORARY | FILE_FLAG_DELETE_ON_CLOSE, - NULL); -} diff --git a/win/targets.vc b/win/targets.vc new file mode 100644 index 0000000..7f1d388 --- /dev/null +++ b/win/targets.vc @@ -0,0 +1,98 @@ +#------------------------------------------------------------- -*- makefile -*-
+# targets.vc --
+#
+# Part of the nmake based build system for Tcl and its extensions.
+# This file defines some standard targets for the convenience of extensions
+# and can be optionally included by the extension makefile.
+# See TIP 477 (https://core.tcl.tk/tips/doc/trunk/tip/477.md) for docs.
+
+$(PROJECT): setup pkgindex $(PRJLIB)
+
+!ifdef PRJ_STUBOBJS
+$(PROJECT): $(PRJSTUBLIB)
+$(PRJSTUBLIB): $(PRJ_STUBOBJS)
+ $(LIBCMD) $**
+
+$(PRJ_STUBOBJS):
+ $(CCSTUBSCMD) %s
+!endif # PRJ_STUBOBJS
+
+!ifdef PRJ_MANIFEST
+$(PROJECT): $(PRJLIB).manifest
+$(PRJLIB).manifest: $(PRJ_MANIFEST)
+ @nmakehlp -s << $** >$@
+@MACHINE@ $(MACHINE:IX86=X86)
+<<
+!endif
+
+!if "$(PROJECT)" != "tcl" && "$(PROJECT)" != "tk"
+$(PRJLIB): $(PRJ_OBJS) $(RESFILE)
+!if $(STATIC_BUILD)
+ $(LIBCMD) $**
+!else
+ $(DLLCMD) $**
+ $(_VC_MANIFEST_EMBED_DLL)
+!endif
+ -@del $*.exp
+!endif
+
+!if "$(PRJ_HEADERS)" != "" && "$(PRJ_OBJS)" != ""
+$(PRJ_OBJS): $(PRJ_HEADERS)
+!endif
+
+# If parent makefile has defined stub objects, add their installation
+# to the default install
+!if "$(PRJ_STUBOBJS)" != ""
+default-install: default-install-stubs
+!endif
+
+# Unlike the other default targets, these cannot be in rules.vc because
+# the executed command depends on existence of macro PRJ_HEADERS_PUBLIC
+# that the parent makefile will not define until after including rules-ext.vc
+!if "$(PRJ_HEADERS_PUBLIC)" != ""
+default-install: default-install-headers
+default-install-headers:
+ @echo Installing headers to '$(INCLUDE_INSTALL_DIR)'
+ @for %f in ($(PRJ_HEADERS_PUBLIC)) do @$(COPY) %f "$(INCLUDE_INSTALL_DIR)"
+!endif
+
+!if "$(DISABLE_STANDARD_TARGETS)" == ""
+DISABLE_STANDARD_TARGETS = 0
+!endif
+
+!if "$(DISABLE_TARGET_setup)" == ""
+DISABLE_TARGET_setup = 0
+!endif
+!if "$(DISABLE_TARGET_install)" == ""
+DISABLE_TARGET_install = 0
+!endif
+!if "$(DISABLE_TARGET_clean)" == ""
+DISABLE_TARGET_clean = 0
+!endif
+!if "$(DISABLE_TARGET_test)" == ""
+DISABLE_TARGET_test = 0
+!endif
+!if "$(DISABLE_TARGET_shell)" == ""
+DISABLE_TARGET_shell = 0
+!endif
+
+!if !$(DISABLE_STANDARD_TARGETS)
+!if !$(DISABLE_TARGET_setup)
+setup: default-setup
+!endif
+!if !$(DISABLE_TARGET_install)
+install: default-install
+!endif
+!if !$(DISABLE_TARGET_clean)
+clean: default-clean
+realclean: hose
+hose: default-hose
+distclean: realclean default-distclean
+!endif
+!if !$(DISABLE_TARGET_test)
+test: default-test
+!endif
+!if !$(DISABLE_TARGET_shell)
+shell: default-shell
+!endif
+!endif # DISABLE_STANDARD_TARGETS
diff --git a/win/tcl.dsp b/win/tcl.dsp index 2e5ad14..e8b1a33 100644 --- a/win/tcl.dsp +++ b/win/tcl.dsp @@ -36,7 +36,7 @@ CFG=tcl - Win32 Debug Static # PROP BASE Intermediate_Dir "Release\tcl_Dynamic"
# PROP BASE Cmd_Line "nmake -nologo -f makefile.vc OPTS=none MSVCDIR=IDE"
# PROP BASE Rebuild_Opt "-a"
-# PROP BASE Target_File "Release\tclsh85.exe"
+# PROP BASE Target_File "Release\tclsh86.exe"
# PROP BASE Bsc_Name ""
# PROP BASE Target_Dir ""
# PROP Use_MFC 0
@@ -45,7 +45,7 @@ CFG=tcl - Win32 Debug Static # PROP Intermediate_Dir "Release\tcl_Dynamic"
# PROP Cmd_Line "nmake -nologo -f makefile.vc OPTS=threads MSVCDIR=IDE"
# PROP Rebuild_Opt "clean release"
-# PROP Target_File "Release\tclsh85t.exe"
+# PROP Target_File "Release\tclsh86t.exe"
# PROP Bsc_Name ""
# PROP Target_Dir ""
@@ -57,7 +57,7 @@ CFG=tcl - Win32 Debug Static # PROP BASE Intermediate_Dir "Debug\tcl_Dynamic"
# PROP BASE Cmd_Line "nmake -nologo -f makefile.vc OPTS=symbols MSVCDIR=IDE"
# PROP BASE Rebuild_Opt "-a"
-# PROP BASE Target_File "Debug\tclsh85g.exe"
+# PROP BASE Target_File "Debug\tclsh86g.exe"
# PROP BASE Bsc_Name ""
# PROP BASE Target_Dir ""
# PROP Use_MFC 0
@@ -66,7 +66,7 @@ CFG=tcl - Win32 Debug Static # PROP Intermediate_Dir "Debug\tcl_Dynamic"
# PROP Cmd_Line "nmake -nologo -f makefile.vc OPTS=threads,symbols MSVCDIR=IDE"
# PROP Rebuild_Opt "clean release"
-# PROP Target_File "Debug\tclsh85tg.exe"
+# PROP Target_File "Debug\tclsh86tg.exe"
# PROP Bsc_Name ""
# PROP Target_Dir ""
@@ -78,7 +78,7 @@ CFG=tcl - Win32 Debug Static # PROP BASE Intermediate_Dir "Debug\tcl_Static"
# PROP BASE Cmd_Line "nmake -nologo -f makefile.vc OPTS=symbols,static MSVCDIR=IDE"
# PROP BASE Rebuild_Opt "-a"
-# PROP BASE Target_File "Debug\tclsh85sg.exe"
+# PROP BASE Target_File "Debug\tclsh86sg.exe"
# PROP BASE Bsc_Name ""
# PROP BASE Target_Dir ""
# PROP Use_MFC 0
@@ -87,7 +87,7 @@ CFG=tcl - Win32 Debug Static # PROP Intermediate_Dir "Debug\tcl_Static"
# PROP Cmd_Line "nmake -nologo -f makefile.vc OPTS=symbols,static MSVCDIR=IDE"
# PROP Rebuild_Opt "-a"
-# PROP Target_File "Debug\tclsh85sg.exe"
+# PROP Target_File "Debug\tclsh86sg.exe"
# PROP Bsc_Name ""
# PROP Target_Dir ""
@@ -99,7 +99,7 @@ CFG=tcl - Win32 Debug Static # PROP BASE Intermediate_Dir "Release\tcl_Static"
# PROP BASE Cmd_Line "nmake -nologo -f makefile.vc OPTS=static MSVCDIR=IDE"
# PROP BASE Rebuild_Opt "-a"
-# PROP BASE Target_File "Release\tclsh85s.exe"
+# PROP BASE Target_File "Release\tclsh86s.exe"
# PROP BASE Bsc_Name ""
# PROP BASE Target_Dir ""
# PROP Use_MFC 0
@@ -108,7 +108,7 @@ CFG=tcl - Win32 Debug Static # PROP Intermediate_Dir "Release\tcl_Static"
# PROP Cmd_Line "nmake -nologo -f makefile.vc OPTS=static MSVCDIR=IDE"
# PROP Rebuild_Opt "-a"
-# PROP Target_File "Release\tclsh85s.exe"
+# PROP Target_File "Release\tclsh86s.exe"
# PROP Bsc_Name ""
# PROP Target_Dir ""
@@ -1300,6 +1300,14 @@ SOURCE=..\generic\tclStubLib.c # End Source File
# Begin Source File
+SOURCE=..\generic\tclOOStubLib.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclTomMathStubLib.c
+# End Source File
+# Begin Source File
+
SOURCE=..\generic\tclTest.c
# End Source File
# Begin Source File
@@ -1420,10 +1428,6 @@ SOURCE=.\configure.in # End Source File
# Begin Source File
-SOURCE=.\makefile.bc
-# End Source File
-# Begin Source File
-
SOURCE=.\Makefile.in
# End Source File
# Begin Source File
@@ -1452,10 +1456,6 @@ SOURCE=.\rules.vc # End Source File
# Begin Source File
-SOURCE=.\stub16.c
-# End Source File
-# Begin Source File
-
SOURCE=.\tcl.hpj.in
# End Source File
# Begin Source File
diff --git a/win/tcl.hpj.in b/win/tcl.hpj.in index 8efff0b..a94cea6 100644 --- a/win/tcl.hpj.in +++ b/win/tcl.hpj.in @@ -5,9 +5,9 @@ HCW=0 LCID=0x409 0x0 0x0 ;English (United States)
REPORT=Yes
TITLE=Tcl/Tk Reference Manual
-CNT=tcl85.cnt
+CNT=tcl86.cnt
COPYRIGHT=Copyright © 2000 Ajuba Solutions
-HLP=tcl85.hlp
+HLP=tcl86.hlp
[FILES]
tcl.rtf
@@ -247,7 +247,7 @@ AC_DEFUN([SC_PATH_TKCONFIG], [ # # Results: # -# Subst the following vars: +# Substitutes the following vars: # TCL_BIN_DIR # TCL_SRC_DIR # TCL_LIB_FILE @@ -401,11 +401,11 @@ AC_DEFUN([SC_ENABLE_SHARED], [ AC_DEFUN([SC_ENABLE_THREADS], [ AC_MSG_CHECKING(for building with threads) - AC_ARG_ENABLE(threads, [ --enable-threads build with threads (default: off)], - [tcl_ok=$enableval], [tcl_ok=no]) + AC_ARG_ENABLE(threads, [ --enable-threads build with threads (default: on)], + [tcl_ok=$enableval], [tcl_ok=yes]) if test "$tcl_ok" = "yes"; then - AC_MSG_RESULT(yes) + AC_MSG_RESULT([yes (default)]) TCL_THREADS=1 AC_DEFINE(TCL_THREADS) # USE_THREAD_ALLOC tells us to try the special thread-based @@ -413,7 +413,7 @@ AC_DEFUN([SC_ENABLE_THREADS], [ AC_DEFINE(USE_THREAD_ALLOC) else TCL_THREADS=0 - AC_MSG_RESULT([no (default)]) + AC_MSG_RESULT(no) fi AC_SUBST(TCL_THREADS) ]) @@ -557,6 +557,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ # Set some defaults (may get changed below) EXTRA_CFLAGS="" + AC_DEFINE(MODULE_SCOPE, [extern], [No need to mark inidividual symbols as hidden]) AC_CHECK_PROG(CYGPATH, cygpath, cygpath -m, echo) @@ -571,7 +572,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ AC_CACHE_CHECK(for cross-compile version of gcc, ac_cv_cross, AC_TRY_COMPILE([ - #ifndef __WIN32__ + #ifndef _WIN32 #error cross-compiler #endif ], [], @@ -638,7 +639,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ AC_CACHE_CHECK(for mingw32 version of gcc, ac_cv_win32, AC_TRY_COMPILE([ - #ifdef __WIN32__ + #ifdef _WIN32 #error win32 #endif ], [], @@ -648,13 +649,31 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ if test "$ac_cv_win32" != "yes"; then AC_MSG_ERROR([${CC} cannot produce win32 executables.]) fi + + hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -mwindows -municode -Dmain=xxmain" + AC_CACHE_CHECK(for working -municode linker flag, + ac_cv_municode, + AC_TRY_LINK([ + #include <windows.h> + int APIENTRY wWinMain(HINSTANCE a, HINSTANCE b, LPWSTR c, int d) {return 0;} + ], + [], + ac_cv_municode=yes, + ac_cv_municode=no) + ) + CFLAGS=$hold_cflags + if test "$ac_cv_municode" = "yes" ; then + extra_ldflags="$extra_ldflags -municode" + else + extra_cflags="$extra_cflags -DTCL_BROKEN_MAINARGS" + fi fi AC_MSG_CHECKING([compiler flags]) if test "${GCC}" = "yes" ; then SHLIB_LD="" - SHLIB_LD_LIBS="" - LIBS="-lws2_32" + SHLIB_LD_LIBS='${LIBS}' + LIBS="-lnetapi32 -lkernel32 -luser32 -ladvapi32 -luserenv -lws2_32" # mingw needs to link ole32 and oleaut32 for [send], but MSVC doesn't LIBS_GUI="-lgdi32 -lcomdlg32 -limm32 -lcomctl32 -lshell32 -luuid -lole32 -loleaut32" STLIB_LD='${AR} cr' @@ -673,9 +692,6 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ # static AC_MSG_RESULT([using static flags]) runtime= - MAKE_DLL="echo " - LIBSUFFIX="s\${DBGX}.a" - LIBFLAGSUFFIX="s\${DBGX}" LIBRARIES="\${STATIC_LIBRARIES}" EXESUFFIX="s\${DBGX}.exe" else @@ -689,29 +705,29 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ fi runtime= - # Link with gcc since ld does not link to default libs like - # -luser32 and -lmsvcrt by default. - SHLIB_LD='${CC} -shared' - SHLIB_LD_LIBS='${LIBS}' # Add SHLIB_LD_LIBS to the Make rule, not here. - MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -o \[$]@ ${extra_ldflags} \ - -Wl,--out-implib,\$(patsubst %.dll,lib%.a,\[$]@)" - LIBSUFFIX="\${DBGX}.a" - LIBFLAGSUFFIX="\${DBGX}" EXESUFFIX="\${DBGX}.exe" LIBRARIES="\${SHARED_LIBRARIES}" fi + # Link with gcc since ld does not link to default libs like + # -luser32 and -lmsvcrt by default. + SHLIB_LD='${CC} -shared' + SHLIB_LD_LIBS='${LIBS}' + MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -o \[$]@ ${extra_ldflags} \ + -Wl,--out-implib,\$(patsubst %.dll,lib%.a,\[$]@)" # DLLSUFFIX is separate because it is the building block for # users of tclConfig.sh that may build shared or static. DLLSUFFIX="\${DBGX}.dll" + LIBSUFFIX="\${DBGX}.a" + LIBFLAGSUFFIX="\${DBGX}" SHLIB_SUFFIX=.dll EXTRA_CFLAGS="${extra_cflags}" CFLAGS_DEBUG=-g CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer" - CFLAGS_WARNING="-Wall" + CFLAGS_WARNING="-Wall -Wdeclaration-after-statement" LDFLAGS_DEBUG= LDFLAGS_OPTIMIZE= @@ -766,23 +782,15 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ # static AC_MSG_RESULT([using static flags]) runtime=-MT - MAKE_DLL="echo " - LIBSUFFIX="s\${DBGX}.lib" - LIBFLAGSUFFIX="s\${DBGX}" LIBRARIES="\${STATIC_LIBRARIES}" EXESUFFIX="s\${DBGX}.exe" - SHLIB_LD_LIBS="" else # dynamic AC_MSG_RESULT([using shared flags]) runtime=-MD # Add SHLIB_LD_LIBS to the Make rule, not here. - MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -out:\[$]@" - LIBSUFFIX="\${DBGX}.lib" - LIBFLAGSUFFIX="\${DBGX}" - EXESUFFIX="\${DBGX}.exe" LIBRARIES="\${SHARED_LIBRARIES}" - SHLIB_LD_LIBS='${LIBS}' + EXESUFFIX="\${DBGX}.exe" case "x`echo \${VisualStudioVersion}`" in x1[[4-9]]*) lflags="${lflags} -nodefaultlib:libucrt.lib" @@ -791,9 +799,12 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ ;; esac fi + MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -out:\[$]@" # DLLSUFFIX is separate because it is the building block for # users of tclConfig.sh that may build shared or static. DLLSUFFIX="\${DBGX}.dll" + LIBSUFFIX="\${DBGX}.lib" + LIBFLAGSUFFIX="\${DBGX}" # This is a 2-stage check to make sure we have the 64-bit SDK # We have to know where the SDK is installed. @@ -820,7 +831,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ AC_MSG_RESULT([ Using 64-bit $MACHINE mode]) fi - LIBS="user32.lib advapi32.lib ws2_32.lib" + LIBS="netapi32.lib kernel32.lib user32.lib advapi32.lib userenv.lib ws2_32.lib" case "x`echo \${VisualStudioVersion}`" in x1[[4-9]]*) @@ -954,6 +965,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ fi SHLIB_LD="${LINKBIN} -dll -incremental:no ${lflags}" + SHLIB_LD_LIBS='${LIBS}' # link -lib only works when -lib is the first arg STLIB_LD="${LINKBIN} -lib ${lflags}" RC_OUT=-fo @@ -1114,13 +1126,13 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ #------------------------------------------------------------------------ AC_DEFUN([SC_WITH_TCL], [ - if test -d ../../tcl8.5$1/win; then - TCL_BIN_DEFAULT=../../tcl8.5$1/win + if test -d ../../tcl8.6$1/win; then + TCL_BIN_DEFAULT=../../tcl8.6$1/win else - TCL_BIN_DEFAULT=../../tcl8.5/win + TCL_BIN_DEFAULT=../../tcl8.6/win fi - AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl 8.5 binaries from DIR], + AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl 8.6 binaries from DIR], TCL_BIN_DIR=$withval, TCL_BIN_DIR=`cd $TCL_BIN_DEFAULT; pwd`) if test ! -d $TCL_BIN_DIR; then AC_MSG_ERROR(Tcl directory $TCL_BIN_DIR does not exist) diff --git a/win/tclAppInit.c b/win/tclAppInit.c index 251a610..2236da3 100644 --- a/win/tclAppInit.c +++ b/win/tclAppInit.c @@ -2,31 +2,69 @@ * tclAppInit.c -- * * Provides a default version of the main program and Tcl_AppInit - * function for Tcl applications (without Tk). Note that this program - * must be built in Win32 console mode to work properly. + * procedure for tclsh and other Tcl-based applications (without Tk). + * Note that this program must be built in Win32 console mode to work + * properly. * - * Copyright (c) 1996-1997 by Sun Microsystems, Inc. - * Copyright (c) 1998-1999 by Scriptics Corporation. + * Copyright (c) 1993 The Regents of the University of California. + * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 1998-1999 Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tcl.h" +#define WIN32_LEAN_AND_MEAN +#define STRICT /* See MSDN Article Q83456 */ #include <windows.h> +#undef STRICT +#undef WIN32_LEAN_AND_MEAN #include <locale.h> +#include <stdlib.h> +#include <tchar.h> #ifdef TCL_TEST -extern Tcl_PackageInitProc Procbodytest_Init; -extern Tcl_PackageInitProc Procbodytest_SafeInit; -extern Tcl_PackageInitProc Tcltest_Init; -extern Tcl_PackageInitProc TclObjTest_Init; +extern Tcl_PackageInitProc Tcltest_Init; +extern Tcl_PackageInitProc Tcltest_SafeInit; #endif /* TCL_TEST */ -#if defined(__GNUC__) +#if defined(STATIC_BUILD) && TCL_USE_STATIC_PACKAGES +extern Tcl_PackageInitProc Registry_Init; +extern Tcl_PackageInitProc Dde_Init; +extern Tcl_PackageInitProc Dde_SafeInit; +#endif + +#if defined(__GNUC__) || defined(TCL_BROKEN_MAINARGS) int _CRT_glob = 0; -static void setargv(int *argcPtr, char ***argvPtr); -#endif /* __GNUC__ */ +#endif /* __GNUC__ || TCL_BROKEN_MAINARGS */ +#ifdef TCL_BROKEN_MAINARGS +static void setargv(int *argcPtr, TCHAR ***argvPtr); +#endif /* TCL_BROKEN_MAINARGS */ + +/* + * The following #if block allows you to change the AppInit function by using + * a #define of TCL_LOCAL_APPINIT instead of rewriting this entire file. The + * #if checks for that #define and uses Tcl_AppInit if it does not exist. + */ + +#ifndef TCL_LOCAL_APPINIT +#define TCL_LOCAL_APPINIT Tcl_AppInit +#endif +#ifndef MODULE_SCOPE +# define MODULE_SCOPE extern +#endif +MODULE_SCOPE int TCL_LOCAL_APPINIT(Tcl_Interp *); + +/* + * The following #if block allows you to change how Tcl finds the startup + * script, prime the library or encoding paths, fiddle with the argv, etc., + * without needing to rewrite Tcl_Main() + */ + +#ifdef TCL_LOCAL_MAIN_HOOK +MODULE_SCOPE int TCL_LOCAL_MAIN_HOOK(int *argc, TCHAR ***argv); +#endif /* *---------------------------------------------------------------------- @@ -36,53 +74,45 @@ static void setargv(int *argcPtr, char ***argvPtr); * This is the main program for the application. * * Results: - * None: Tcl_Main never returns here, so this function never returns + * None: Tcl_Main never returns here, so this procedure never returns * either. * * Side effects: - * Whatever the application does. + * Just about anything, since from here we call arbitrary Tcl code. * *---------------------------------------------------------------------- */ +#ifdef TCL_BROKEN_MAINARGS int main( - int argc, - char *argv[]) + int argc, /* Number of command-line arguments. */ + char *dummy[]) /* Not used. */ +{ + TCHAR **argv; +#else +int +_tmain( + int argc, /* Number of command-line arguments. */ + TCHAR *argv[]) /* Values of command-line arguments. */ { - /* - * The following #if block allows you to change the AppInit function by - * using a #define of TCL_LOCAL_APPINIT instead of rewriting this entire - * file. The #if checks for that #define and uses Tcl_AppInit if it - * doesn't exist. - */ - -#ifndef TCL_LOCAL_APPINIT -#define TCL_LOCAL_APPINIT Tcl_AppInit #endif - extern int TCL_LOCAL_APPINIT (Tcl_Interp *interp); + TCHAR *p; /* - * The following #if block allows you to change how Tcl finds the startup - * script, prime the library or encoding paths, fiddle with the argv, - * etc., without needing to rewrite Tcl_Main() + * Set up the default locale to be standard "C" locale so parsing is + * performed correctly. */ -#ifdef TCL_LOCAL_MAIN_HOOK - extern int TCL_LOCAL_MAIN_HOOK (int *argc, char ***argv); -#endif - - char *p; + setlocale(LC_ALL, "C"); +#ifdef TCL_BROKEN_MAINARGS /* - * Set up the default locale to be standard "C" locale so parsing is - * performed correctly. + * Get our args from the c-runtime. Ignore command line. */ -#if defined(__GNUC__) - setargv( &argc, &argv ); + setargv(&argc, &argv); #endif - setlocale(LC_ALL, "C"); /* * Forward slashes substituted for backslashes. @@ -99,7 +129,6 @@ main( #endif Tcl_Main(argc, argv, TCL_LOCAL_APPINIT); - return 0; /* Needed only to prevent compiler warning. */ } @@ -108,9 +137,9 @@ main( * * Tcl_AppInit -- * - * This function performs application-specific initialization. Most + * This procedure performs application-specific initialization. Most * applications, especially those that incorporate additional packages, - * will have their own version of this function. + * will have their own version of this procedure. * * Results: * Returns a standard Tcl completion code, and leaves an error message in @@ -126,57 +155,44 @@ int Tcl_AppInit( Tcl_Interp *interp) /* Interpreter for application. */ { - if (Tcl_Init(interp) == TCL_ERROR) { + if ((Tcl_Init)(interp) == TCL_ERROR) { return TCL_ERROR; } -#ifdef TCL_TEST - if (Tcltest_Init(interp) == TCL_ERROR) { +#if defined(STATIC_BUILD) && TCL_USE_STATIC_PACKAGES + if (Registry_Init(interp) == TCL_ERROR) { return TCL_ERROR; } - Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, NULL); - if (TclObjTest_Init(interp) == TCL_ERROR) { + Tcl_StaticPackage(interp, "registry", Registry_Init, NULL); + + if (Dde_Init(interp) == TCL_ERROR) { return TCL_ERROR; } - if (Procbodytest_Init(interp) == TCL_ERROR) { + Tcl_StaticPackage(interp, "dde", Dde_Init, Dde_SafeInit); +#endif + +#ifdef TCL_TEST + if (Tcltest_Init(interp) == TCL_ERROR) { return TCL_ERROR; } - Tcl_StaticPackage(interp, "procbodytest", Procbodytest_Init, - Procbodytest_SafeInit); + Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, Tcltest_SafeInit); #endif /* TCL_TEST */ -#if defined(STATIC_BUILD) && TCL_USE_STATIC_PACKAGES - { - extern Tcl_PackageInitProc Registry_Init; - extern Tcl_PackageInitProc Dde_Init; - extern Tcl_PackageInitProc Dde_SafeInit; - - if (Registry_Init(interp) == TCL_ERROR) { - return TCL_ERROR; - } - Tcl_StaticPackage(interp, "registry", Registry_Init, NULL); - - if (Dde_Init(interp) == TCL_ERROR) { - return TCL_ERROR; - } - Tcl_StaticPackage(interp, "dde", Dde_Init, Dde_SafeInit); - } -#endif - /* - * Call the init functions for included packages. Each call should look + * Call the init procedures for included packages. Each call should look * like this: * * if (Mod_Init(interp) == TCL_ERROR) { * return TCL_ERROR; * } * - * where "Mod" is the name of the module. + * where "Mod" is the name of the module. (Dynamically-loadable packages + * should have the same entry-point name.) */ /* * Call Tcl_CreateCommand for application-specific commands, if they - * weren't already created by the init functions called above. + * weren't already created by the init procedures called above. */ /* @@ -186,7 +202,8 @@ Tcl_AppInit( * user-specific startup file will be run under any conditions. */ - Tcl_SetVar(interp, "tcl_rcFileName", "~/tclshrc.tcl", TCL_GLOBAL_ONLY); + (Tcl_ObjSetVar2)(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL, + Tcl_NewStringObj("~/tclshrc.tcl", -1), TCL_GLOBAL_ONLY); return TCL_OK; } @@ -217,17 +234,17 @@ Tcl_AppInit( *-------------------------------------------------------------------------- */ -#if defined(__GNUC__) +#ifdef TCL_BROKEN_MAINARGS static void setargv( int *argcPtr, /* Filled with number of argument strings. */ - char ***argvPtr) /* Filled with argument strings (malloc'd). */ + TCHAR ***argvPtr) /* Filled with argument strings (malloc'd). */ { - char *cmdLine, *p, *arg, *argSpace; - char **argv; + TCHAR *cmdLine, *p, *arg, *argSpace; + TCHAR **argv; int argc, size, inquote, copy, slashes; - cmdLine = GetCommandLine(); /* INTL: BUG */ + cmdLine = GetCommandLine(); /* * Precompute an overly pessimistic guess at the number of arguments in @@ -246,10 +263,15 @@ setargv( } } } - argSpace = (char *) ckalloc( - (unsigned) (size * sizeof(char *) + strlen(cmdLine) + 1)); - argv = (char **) argSpace; - argSpace += size * sizeof(char *); + + /* Make sure we don't call ckalloc through the (not yet initialized) stub table */ + #undef Tcl_Alloc + #undef Tcl_DbCkalloc + + argSpace = ckalloc(size * sizeof(char *) + + (_tcslen(cmdLine) * sizeof(TCHAR)) + sizeof(TCHAR)); + argv = (TCHAR **) argSpace; + argSpace += size * (sizeof(char *)/sizeof(TCHAR)); size--; p = cmdLine; @@ -307,7 +329,7 @@ setargv( *argcPtr = argc; *argvPtr = argv; } -#endif /* __GNUC__ */ +#endif /* TCL_BROKEN_MAINARGS */ /* * Local Variables: diff --git a/win/tclConfig.sh.in b/win/tclConfig.sh.in index 75324b2..6ed06e2 100644 --- a/win/tclConfig.sh.in +++ b/win/tclConfig.sh.in @@ -92,10 +92,11 @@ TCL_DL_LIBS='@DL_LIBS@' # an executable tclsh or tcltest binary. TCL_LD_FLAGS='@LDFLAGS@' -# Flags to pass to ld, such as "-R /usr/local/tcl/lib", that tell the +# Flags to pass to cc/ld, such as "-R /usr/local/tcl/lib", that tell the # run-time dynamic linker where to look for shared libraries such as # libtcl.so. Used when linking applications. Only works if there # is a variable "LIB_RUNTIME_DIR" defined in the Makefile. +TCL_CC_SEARCH_FLAGS='@TCL_CC_SEARCH_FLAGS@' TCL_LD_SEARCH_FLAGS='@TCL_LD_SEARCH_FLAGS@' # Additional object files linked with Tcl to provide compatibility diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c index 560b448..3fb8796 100644 --- a/win/tclWin32Dll.c +++ b/win/tclWin32Dll.c @@ -12,30 +12,9 @@ */ #include "tclWinInt.h" - -#ifndef TCL_NO_STACK_CHECK -/* - * The following functions implement stack depth checking - */ -typedef struct ThreadSpecificData { - int *stackBound; /* The current stack boundary */ -} ThreadSpecificData; -static Tcl_ThreadDataKey dataKey; -#endif /* TCL_NO_STACK_CHECK */ - -/* - * The following data structures are used when loading the thunking library - * for execing child processes under Win32s. - */ - -typedef DWORD (WINAPI UT32PROC)(LPVOID lpBuff, DWORD dwUserDefined, - LPVOID *lpTranslationList); - -typedef BOOL (WINAPI UTREGISTER)(HANDLE hModule, LPCSTR SixteenBitDLL, - LPCSTR InitName, LPCSTR ProcName, UT32PROC **ThirtyTwoBitThunk, - FARPROC UT32Callback, LPVOID Buff); - -typedef VOID (WINAPI UTUNREGISTER)(HANDLE hModule); +#if defined(HAVE_INTRIN_H) +# include <intrin.h> +#endif /* * The following variables keep track of information about this DLL on a @@ -50,154 +29,16 @@ static int platformId; /* Running under NT, or 95/98? */ * VC++ 5.x has no 'cpuid' assembler instruction, so we must emulate it */ -#if defined(_MSC_VER) && (_MSC_VER <= 1100) +#if defined(_MSC_VER) && (_MSC_VER <= 1100) && defined (_M_IX86) #define cpuid __asm __emit 0fh __asm __emit 0a2h #endif /* - * The following function tables are used to dispatch to either the - * wide-character or multi-byte versions of the operating system calls, - * depending on whether the Unicode calls are available. - */ - -static TclWinProcs asciiProcs = { - 0, - - (BOOL (WINAPI *)(CONST TCHAR *, LPDCB)) BuildCommDCBA, - (TCHAR *(WINAPI *)(TCHAR *)) CharLowerA, - (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *, BOOL)) CopyFileA, - (BOOL (WINAPI *)(CONST TCHAR *, LPSECURITY_ATTRIBUTES)) CreateDirectoryA, - (HANDLE (WINAPI *)(CONST TCHAR *, DWORD, DWORD, SECURITY_ATTRIBUTES *, - DWORD, DWORD, HANDLE)) CreateFileA, - (BOOL (WINAPI *)(CONST TCHAR *, TCHAR *, LPSECURITY_ATTRIBUTES, - LPSECURITY_ATTRIBUTES, BOOL, DWORD, LPVOID, CONST TCHAR *, - LPSTARTUPINFOA, LPPROCESS_INFORMATION)) CreateProcessA, - (BOOL (WINAPI *)(CONST TCHAR *)) DeleteFileA, - (HANDLE (WINAPI *)(CONST TCHAR *, WIN32_FIND_DATAT *)) FindFirstFileA, - (BOOL (WINAPI *)(HANDLE, WIN32_FIND_DATAT *)) FindNextFileA, - (BOOL (WINAPI *)(WCHAR *, LPDWORD)) GetComputerNameA, - (DWORD (WINAPI *)(DWORD, WCHAR *)) GetCurrentDirectoryA, - (DWORD (WINAPI *)(CONST TCHAR *)) GetFileAttributesA, - (DWORD (WINAPI *)(CONST TCHAR *, DWORD nBufferLength, WCHAR *, - TCHAR **)) GetFullPathNameA, - (DWORD (WINAPI *)(HMODULE, WCHAR *, int)) GetModuleFileNameA, - (DWORD (WINAPI *)(CONST TCHAR *, WCHAR *, DWORD)) GetShortPathNameA, - (UINT (WINAPI *)(CONST TCHAR *, CONST TCHAR *, UINT uUnique, - WCHAR *)) GetTempFileNameA, - (DWORD (WINAPI *)(DWORD, WCHAR *)) GetTempPathA, - (BOOL (WINAPI *)(CONST TCHAR *, WCHAR *, DWORD, LPDWORD, LPDWORD, LPDWORD, - WCHAR *, DWORD)) GetVolumeInformationA, - (HINSTANCE (WINAPI *)(CONST TCHAR *, HANDLE, DWORD)) LoadLibraryExA, - (TCHAR (WINAPI *)(WCHAR *, CONST TCHAR *)) lstrcpyA, - (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *)) MoveFileA, - (BOOL (WINAPI *)(CONST TCHAR *)) RemoveDirectoryA, - (DWORD (WINAPI *)(CONST TCHAR *, CONST TCHAR *, CONST TCHAR *, DWORD, - WCHAR *, TCHAR **)) SearchPathA, - (BOOL (WINAPI *)(CONST TCHAR *)) SetCurrentDirectoryA, - (BOOL (WINAPI *)(CONST TCHAR *, DWORD)) SetFileAttributesA, - - /* - * The three NULL function pointers will only be set when - * Tcl_FindExecutable is called. If you don't ever call that function, the - * application will crash whenever WinTcl tries to call functions through - * these null pointers. That is not a bug in Tcl - Tcl_FindExecutable is - * mandatory in recent Tcl releases. - */ - - NULL, - NULL, - /* deleted (int (__cdecl*)(CONST TCHAR *, struct _utimbuf *)) _utime, */ - NULL, - NULL, - /* getLongPathNameProc */ - NULL, - /* Security SDK - not available on 95,98,ME */ - NULL, NULL, NULL, NULL, NULL, NULL, - /* ReadConsole and WriteConsole */ - (BOOL (WINAPI *)(HANDLE, LPVOID, DWORD, LPDWORD, LPVOID)) ReadConsoleA, - (BOOL (WINAPI *)(HANDLE, const VOID*, DWORD, LPDWORD, LPVOID)) WriteConsoleA, - (BOOL (WINAPI *)(LPTSTR, LPDWORD)) GetUserNameA -}; - -static TclWinProcs unicodeProcs = { - 1, - - (BOOL (WINAPI *)(CONST TCHAR *, LPDCB)) BuildCommDCBW, - (TCHAR *(WINAPI *)(TCHAR *)) CharLowerW, - (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *, BOOL)) CopyFileW, - (BOOL (WINAPI *)(CONST TCHAR *, LPSECURITY_ATTRIBUTES)) CreateDirectoryW, - (HANDLE (WINAPI *)(CONST TCHAR *, DWORD, DWORD, SECURITY_ATTRIBUTES *, - DWORD, DWORD, HANDLE)) CreateFileW, - (BOOL (WINAPI *)(CONST TCHAR *, TCHAR *, LPSECURITY_ATTRIBUTES, - LPSECURITY_ATTRIBUTES, BOOL, DWORD, LPVOID, CONST TCHAR *, - LPSTARTUPINFOA, LPPROCESS_INFORMATION)) CreateProcessW, - (BOOL (WINAPI *)(CONST TCHAR *)) DeleteFileW, - (HANDLE (WINAPI *)(CONST TCHAR *, WIN32_FIND_DATAT *)) FindFirstFileW, - (BOOL (WINAPI *)(HANDLE, WIN32_FIND_DATAT *)) FindNextFileW, - (BOOL (WINAPI *)(WCHAR *, LPDWORD)) GetComputerNameW, - (DWORD (WINAPI *)(DWORD, WCHAR *)) GetCurrentDirectoryW, - (DWORD (WINAPI *)(CONST TCHAR *)) GetFileAttributesW, - (DWORD (WINAPI *)(CONST TCHAR *, DWORD nBufferLength, WCHAR *, - TCHAR **)) GetFullPathNameW, - (DWORD (WINAPI *)(HMODULE, WCHAR *, int)) GetModuleFileNameW, - (DWORD (WINAPI *)(CONST TCHAR *, WCHAR *, DWORD)) GetShortPathNameW, - (UINT (WINAPI *)(CONST TCHAR *, CONST TCHAR *, UINT uUnique, - WCHAR *)) GetTempFileNameW, - (DWORD (WINAPI *)(DWORD, WCHAR *)) GetTempPathW, - (BOOL (WINAPI *)(CONST TCHAR *, WCHAR *, DWORD, LPDWORD, LPDWORD, LPDWORD, - WCHAR *, DWORD)) GetVolumeInformationW, - (HINSTANCE (WINAPI *)(CONST TCHAR *, HANDLE, DWORD)) LoadLibraryExW, - (TCHAR (WINAPI *)(WCHAR *, CONST TCHAR *)) lstrcpyW, - (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *)) MoveFileW, - (BOOL (WINAPI *)(CONST TCHAR *)) RemoveDirectoryW, - (DWORD (WINAPI *)(CONST TCHAR *, CONST TCHAR *, CONST TCHAR *, DWORD, - WCHAR *, TCHAR **)) SearchPathW, - (BOOL (WINAPI *)(CONST TCHAR *)) SetCurrentDirectoryW, - (BOOL (WINAPI *)(CONST TCHAR *, DWORD)) SetFileAttributesW, - - /* - * The three NULL function pointers will only be set when - * Tcl_FindExecutable is called. If you don't ever call that function, the - * application will crash whenever WinTcl tries to call functions through - * these null pointers. That is not a bug in Tcl - Tcl_FindExecutable is - * mandatory in recent Tcl releases. - */ - - NULL, - NULL, - /* deleted (int (__cdecl*)(CONST TCHAR *, struct _utimbuf *)) _wutime, */ - NULL, - NULL, - /* getLongPathNameProc */ - NULL, - /* Security SDK - will be filled in on NT,XP,2000,2003 */ - NULL, NULL, NULL, NULL, NULL, NULL, - /* ReadConsole and WriteConsole */ - (BOOL (WINAPI *)(HANDLE, LPVOID, DWORD, LPDWORD, LPVOID)) ReadConsoleW, - (BOOL (WINAPI *)(HANDLE, const VOID*, DWORD, LPDWORD, LPVOID)) WriteConsoleW, - (BOOL (WINAPI *)(LPTSTR, LPDWORD)) GetUserNameW -}; - -TclWinProcs *tclWinProcs; -static Tcl_Encoding tclWinTCharEncoding; - -#ifdef HAVE_NO_SEH -/* - * Need to add noinline flag to DllMain declaration so that gcc -O3 does not - * inline asm code into DllEntryPoint and cause a compile time error because - * of redefined local labels. - */ - -BOOL APIENTRY DllMain(HINSTANCE hInst, DWORD reason, - LPVOID reserved) __attribute__ ((noinline)); -#else -/* * The following declaration is for the VC++ DLL entry point. */ BOOL APIENTRY DllMain(HINSTANCE hInst, DWORD reason, LPVOID reserved); -#endif /* HAVE_NO_SEH */ /* * The following structure and linked list is to allow us to map between @@ -206,8 +47,8 @@ BOOL APIENTRY DllMain(HINSTANCE hInst, DWORD reason, */ typedef struct MountPointMap { - CONST WCHAR *volumeName; /* Native wide string volume name. */ - char driveLetter; /* Drive letter corresponding to the volume + TCHAR *volumeName; /* Native wide string volume name. */ + TCHAR driveLetter; /* Drive letter corresponding to the volume * name. */ struct MountPointMap *nextPtr; /* Pointer to next structure in list, or @@ -226,9 +67,7 @@ TCL_DECLARE_MUTEX(mountPointMap) * We will need this below. */ -extern Tcl_FSDupInternalRepProc TclNativeDupInternalRep; - -#ifdef __WIN32__ +#ifdef _WIN32 #ifndef STATIC_BUILD /* @@ -270,10 +109,7 @@ DllEntryPoint( * TRUE on sucess, FALSE on failure. * * Side effects: - * Establishes 32-to-16 bit thunk and initializes sockets library. This - * might call some sycronization functions, but MSDN documentation - * states: "Waiting on synchronization objects in DllMain can cause a - * deadlock." + * Initializes most rudimentary Windows bits. * *---------------------------------------------------------------------- */ @@ -284,111 +120,22 @@ DllMain( DWORD reason, /* Reason this function is being called. */ LPVOID reserved) /* Not used. */ { -#if defined(HAVE_NO_SEH) && !defined(_WIN64) - TCLEXCEPTION_REGISTRATION registration; -#endif - switch (reason) { case DLL_PROCESS_ATTACH: DisableThreadLibraryCalls(hInst); TclWinInit(hInst); return TRUE; - case DLL_PROCESS_DETACH: /* - * Protect the call to Tcl_Finalize. The OS could be unloading us from - * an exception handler and the state of the stack might be unstable. + * DLL_PROCESS_DETACH is unnecessary as the user should call + * Tcl_Finalize explicitly before unloading Tcl. */ - -#if defined(HAVE_NO_SEH) && !defined(_WIN64) - __asm__ __volatile__ ( - - /* - * Construct an TCLEXCEPTION_REGISTRATION to protect the call to - * Tcl_Finalize - */ - - "leal %[registration], %%edx" "\n\t" - "movl %%fs:0, %%eax" "\n\t" - "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ - "leal 1f, %%eax" "\n\t" - "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ - "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ - "movl %%esp, 0xc(%%edx)" "\n\t" /* esp */ - "movl %[error], 0x10(%%edx)" "\n\t" /* status */ - - /* - * Link the TCLEXCEPTION_REGISTRATION on the chain - */ - - "movl %%edx, %%fs:0" "\n\t" - - /* - * Call Tcl_Finalize - */ - - "call _Tcl_Finalize" "\n\t" - - /* - * Come here on a normal exit. Recover the TCLEXCEPTION_REGISTRATION - * and store a TCL_OK status - */ - - "movl %%fs:0, %%edx" "\n\t" - "movl %[ok], %%eax" "\n\t" - "movl %%eax, 0x10(%%edx)" "\n\t" - "jmp 2f" "\n" - - /* - * Come here on an exception. Get the TCLEXCEPTION_REGISTRATION that - * we previously put on the chain. - */ - - "1:" "\t" - "movl %%fs:0, %%edx" "\n\t" - "movl 0x8(%%edx), %%edx" "\n" - - - /* - * Come here however we exited. Restore context from the - * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. - */ - - "2:" "\t" - "movl 0xc(%%edx), %%esp" "\n\t" - "movl 0x8(%%edx), %%ebp" "\n\t" - "movl 0x0(%%edx), %%eax" "\n\t" - "movl %%eax, %%fs:0" "\n\t" - - : - /* No outputs */ - : - [registration] "m" (registration), - [ok] "i" (TCL_OK), - [error] "i" (TCL_ERROR) - : - "%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "memory" - ); - -#else -#ifndef HAVE_NO_SEH - __try { -#endif - Tcl_Finalize(); -#ifndef HAVE_NO_SEH - } __except (EXCEPTION_EXECUTE_HANDLER) { - /* empty handler body. */ - } -#endif -#endif - - break; } return TRUE; } #endif /* !STATIC_BUILD */ -#endif /* __WIN32__ */ +#endif /* _WIN32 */ /* *---------------------------------------------------------------------- @@ -440,15 +187,16 @@ TclWinInit( platformId = os.dwPlatformId; /* - * We no longer support Win32s, so just in case someone manages to get a - * runtime there, make sure they know that. + * We no longer support Win32s or Win9x, so just in case someone manages + * to get a runtime there, make sure they know that. */ if (platformId == VER_PLATFORM_WIN32s) { Tcl_Panic("Win32s is not a supported platform"); } - - tclWinProcs = &asciiProcs; + if (platformId == VER_PLATFORM_WIN32_WINDOWS) { + Tcl_Panic("Windows 9x is not a supported platform"); + } } /* @@ -461,9 +209,10 @@ TclWinInit( * * Results: * The return value is one of: - * VER_PLATFORM_WIN32s Win32s on Windows 3.1. (not supported) - * VER_PLATFORM_WIN32_WINDOWS Win32 on Windows 95, 98, ME. - * VER_PLATFORM_WIN32_NT Win32 on Windows NT, 2000, XP + * VER_PLATFORM_WIN32s Win32s on Windows 3.1 (not supported) + * VER_PLATFORM_WIN32_WINDOWS Win32 on Windows 95, 98, ME (not supported) + * VER_PLATFORM_WIN32_NT Win32 on Windows NT, 2000, XP + * VER_PLATFORM_WIN32_CE Win32 on Windows CE * * Side effects: * None. @@ -509,95 +258,11 @@ TclWinNoBackslash( } /* - *---------------------------------------------------------------------- - * - * TclpGetStackParams -- - * - * Determine the stack params for the current thread: in which - * direction does the stack grow, and what is the stack lower (resp. - * upper) bound for safe invocation of a new command? This is used to - * cache the values needed for an efficient computation of - * TclpCheckStackSpace() when the interp is known. - * - * Results: - * Returns 1 if the stack grows down, in which case a stack lower bound - * is stored at stackBoundPtr. If the stack grows up, 0 is returned and - * an upper bound is stored at stackBoundPtr. If a bound cannot be - * determined NULL is stored at stackBoundPtr. - * - *---------------------------------------------------------------------- - */ - -#ifndef TCL_NO_STACK_CHECK -int -TclpGetCStackParams( - int **stackBoundPtr) -{ - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - SYSTEM_INFO si; /* The system information, used to - * determine the page size */ - MEMORY_BASIC_INFORMATION mbi; - /* The information about the memory - * area in which the stack resides */ - - if (!tsdPtr->stackBound - || ((UINT_PTR)&tsdPtr < (UINT_PTR)tsdPtr->stackBound)) { - - /* - * Either we haven't determined the stack bound in this thread, - * or else we've overflowed the bound that we previously - * determined. We need to find a new stack bound from - * Windows. - */ - - GetSystemInfo(&si); - if (VirtualQuery((LPCVOID) &tsdPtr, &mbi, sizeof(mbi)) == 0) { - - /* For some reason, the system didn't let us query the - * stack size. Nevertheless, we got here and haven't - * blown up yet. Don't update the calculated stack bound. - * If there is no calculated stack bound yet, set it to - * the base of the current page of stack. */ - - if (!tsdPtr->stackBound) { - tsdPtr->stackBound = - (int*) ((UINT_PTR)(&tsdPtr) - & ~ (UINT_PTR)(si.dwPageSize - 1)); - } - - } else { - - /* The allocation base of the stack segment has to be advanced - * by one page (to allow for the guard page maintained in the - * C runtime) and then by TCL_WIN_STACK_THRESHOLD (to allow - * for the amount of stack that Tcl needs). - */ - - tsdPtr->stackBound = - (int*) ((UINT_PTR)(mbi.AllocationBase) - + (UINT_PTR)(si.dwPageSize) - + TCL_WIN_STACK_THRESHOLD); - } - } - *stackBoundPtr = tsdPtr->stackBound; - return 1; -} -#endif - - -/* *--------------------------------------------------------------------------- * - * TclWinSetInterfaces -- + * TclpSetInterfaces -- * - * 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. - * - * As well as this, we can also try to load in some additional procs - * which may/may not be present depending on the current Windows version - * (e.g. Win95 will not have the procs below). + * A helper proc. * * Results: * None. @@ -609,107 +274,16 @@ TclpGetCStackParams( */ void -TclWinSetInterfaces( - int wide) /* Non-zero to use wide interfaces, 0 - * otherwise. */ +TclpSetInterfaces(void) { - Tcl_FreeEncoding(tclWinTCharEncoding); - - if (wide) { - tclWinProcs = &unicodeProcs; - tclWinTCharEncoding = Tcl_GetEncoding(NULL, "unicode"); - if (tclWinProcs->getFileAttributesExProc == NULL) { - HMODULE handle = GetModuleHandle(TEXT("KERNEL32")); - tclWinProcs->getFileAttributesExProc = - (BOOL (WINAPI *)(CONST TCHAR *, GET_FILEEX_INFO_LEVELS, - LPVOID)) GetProcAddress(handle, - "GetFileAttributesExW"); - tclWinProcs->createHardLinkProc = - (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR*, - LPSECURITY_ATTRIBUTES)) GetProcAddress(handle, - "CreateHardLinkW"); - tclWinProcs->findFirstFileExProc = - (HANDLE (WINAPI *)(CONST TCHAR*, UINT, LPVOID, UINT, - LPVOID, DWORD)) GetProcAddress(handle, - "FindFirstFileExW"); - tclWinProcs->getVolumeNameForVMPProc = - (BOOL (WINAPI *)(CONST TCHAR*, TCHAR*, - DWORD)) GetProcAddress(handle, - "GetVolumeNameForVolumeMountPointW"); - tclWinProcs->getLongPathNameProc = - (DWORD (WINAPI *)(CONST TCHAR*, TCHAR*, - DWORD)) GetProcAddress(handle, "GetLongPathNameW"); - - handle = GetModuleHandle(TEXT("ADVAPI32")); - tclWinProcs->getFileSecurityProc = (BOOL (WINAPI *)( - LPCTSTR lpFileName, - SECURITY_INFORMATION RequestedInformation, - PSECURITY_DESCRIPTOR pSecurityDescriptor, - DWORD nLength, LPDWORD lpnLengthNeeded)) - GetProcAddress(handle, "GetFileSecurityW"); - tclWinProcs->impersonateSelfProc = (BOOL (WINAPI *) ( - SECURITY_IMPERSONATION_LEVEL ImpersonationLevel)) - GetProcAddress(handle, "ImpersonateSelf"); - tclWinProcs->openThreadTokenProc = (BOOL (WINAPI *) ( - HANDLE ThreadHandle, DWORD DesiredAccess, - BOOL OpenAsSelf, PHANDLE TokenHandle)) - GetProcAddress(handle, "OpenThreadToken"); - tclWinProcs->revertToSelfProc = (BOOL (WINAPI *) (void)) - GetProcAddress(handle, "RevertToSelf"); - tclWinProcs->mapGenericMaskProc = (VOID (WINAPI *) ( - PDWORD AccessMask, PGENERIC_MAPPING GenericMapping)) - GetProcAddress(handle, "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(handle, - "AccessCheck"); - } - } else { - tclWinProcs = &asciiProcs; - tclWinTCharEncoding = NULL; - if (tclWinProcs->getFileAttributesExProc == NULL) { - HMODULE handle = GetModuleHandle(TEXT("KERNEL32")); - tclWinProcs->getFileAttributesExProc = - (BOOL (WINAPI *)(CONST TCHAR *, GET_FILEEX_INFO_LEVELS, - LPVOID)) GetProcAddress(handle, - "GetFileAttributesExA"); - tclWinProcs->createHardLinkProc = - (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR*, - LPSECURITY_ATTRIBUTES)) GetProcAddress(handle, - "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(handle, - * "FindFirstFileExA"); - */ - tclWinProcs->getVolumeNameForVMPProc = - (BOOL (WINAPI *)(CONST TCHAR*, TCHAR*, - DWORD)) GetProcAddress(handle, - "GetVolumeNameForVolumeMountPointA"); - } - } } /* *--------------------------------------------------------------------------- * - * TclWinResetInterfaceEncodings -- + * TclWinEncodingsCleanup -- * - * Called during finalization to free up any encodings we use. The - * tclWinProcs-> look up table is still ok to use after this call, - * provided no encoding conversion is required. + * Called during finalization to free up any encodings we use. * * We also clean up any memory allocated in our mount point map which is * used to follow certain kinds of symlinks. That code should never be @@ -725,13 +299,9 @@ TclWinSetInterfaces( */ void -TclWinResetInterfaceEncodings(void) +TclWinEncodingsCleanup(void) { MountPointMap *dlIter, *dlIter2; - if (tclWinTCharEncoding != NULL) { - Tcl_FreeEncoding(tclWinTCharEncoding); - tclWinTCharEncoding = NULL; - } /* * Clean up the mount point map. @@ -741,8 +311,8 @@ TclWinResetInterfaceEncodings(void) dlIter = driveLetterLookup; while (dlIter != NULL) { dlIter2 = dlIter->nextPtr; - ckfree((char*)dlIter->volumeName); - ckfree((char*)dlIter); + ckfree(dlIter->volumeName); + ckfree(dlIter); dlIter = dlIter2; } Tcl_MutexUnlock(&mountPointMap); @@ -754,8 +324,6 @@ TclWinResetInterfaceEncodings(void) * TclWinResetInterfaces -- * * Called during finalization to reset us to a safe state for reuse. - * After this call, it is best not to use the tclWinProcs-> look up table - * since it is likely to be different to what is expected. * * Results: * None. @@ -768,7 +336,6 @@ TclWinResetInterfaceEncodings(void) void TclWinResetInterfaces(void) { - tclWinProcs = &asciiProcs; } /* @@ -795,11 +362,11 @@ TclWinResetInterfaces(void) char TclWinDriveLetterForVolMountPoint( - CONST WCHAR *mountPoint) + const TCHAR *mountPoint) { MountPointMap *dlIter, *dlPtr2; - WCHAR Target[55]; /* Target of mount at mount point */ - WCHAR drive[4] = { L'A', L':', L'\\', L'\0' }; + TCHAR Target[55]; /* Target of mount at mount point */ + TCHAR drive[4] = TEXT("A:\\"); /* * Detect the volume mounted there. Unfortunately, there is no simple way @@ -810,28 +377,28 @@ TclWinDriveLetterForVolMountPoint( Tcl_MutexLock(&mountPointMap); dlIter = driveLetterLookup; while (dlIter != NULL) { - if (wcscmp(dlIter->volumeName, mountPoint) == 0) { + if (_tcscmp(dlIter->volumeName, mountPoint) == 0) { /* * We need to check whether this information is still valid, since * either the user or various programs could have adjusted the * mount points on the fly. */ - drive[0] = L'A' + (dlIter->driveLetter - 'A'); + drive[0] = (TCHAR) dlIter->driveLetter; /* * Try to read the volume mount point and see where it points. */ - if ((*tclWinProcs->getVolumeNameForVMPProc)((TCHAR*)drive, - (TCHAR*)Target, 55) != 0) { - if (wcscmp((WCHAR*)dlIter->volumeName, Target) == 0) { + if (GetVolumeNameForVolumeMountPoint(drive, + Target, 55) != 0) { + if (_tcscmp(dlIter->volumeName, Target) == 0) { /* * Nothing has changed. */ Tcl_MutexUnlock(&mountPointMap); - return dlIter->driveLetter; + return (char) dlIter->driveLetter; } } @@ -858,8 +425,8 @@ TclWinDriveLetterForVolMountPoint( * Now dlPtr2 points to the structure to free. */ - ckfree((char*)dlPtr2->volumeName); - ckfree((char*)dlPtr2); + ckfree(dlPtr2->volumeName); + ckfree(dlPtr2); /* * Restart the loop - we could try to be clever and continue half @@ -882,23 +449,23 @@ TclWinDriveLetterForVolMountPoint( * Try to read the volume mount point and see where it points. */ - if ((*tclWinProcs->getVolumeNameForVMPProc)((TCHAR*)drive, - (TCHAR*)Target, 55) != 0) { + if (GetVolumeNameForVolumeMountPoint(drive, + Target, 55) != 0) { int alreadyStored = 0; for (dlIter = driveLetterLookup; dlIter != NULL; dlIter = dlIter->nextPtr) { - if (wcscmp((WCHAR*)dlIter->volumeName, Target) == 0) { + if (_tcscmp(dlIter->volumeName, Target) == 0) { alreadyStored = 1; break; } } if (!alreadyStored) { - dlPtr2 = (MountPointMap *) ckalloc(sizeof(MountPointMap)); + dlPtr2 = ckalloc(sizeof(MountPointMap)); dlPtr2->volumeName = TclNativeDupInternalRep(Target); - dlPtr2->driveLetter = 'A' + (drive[0] - L'A'); + dlPtr2->driveLetter = (char) drive[0]; dlPtr2->nextPtr = driveLetterLookup; - driveLetterLookup = dlPtr2; + driveLetterLookup = dlPtr2; } } } @@ -909,9 +476,9 @@ TclWinDriveLetterForVolMountPoint( for (dlIter = driveLetterLookup; dlIter != NULL; dlIter = dlIter->nextPtr) { - if (wcscmp(dlIter->volumeName, mountPoint) == 0) { + if (_tcscmp(dlIter->volumeName, mountPoint) == 0) { Tcl_MutexUnlock(&mountPointMap); - return dlIter->driveLetter; + return (char) dlIter->driveLetter; } } @@ -920,11 +487,11 @@ TclWinDriveLetterForVolMountPoint( * that fact and store '-1' so we don't have to look it up each time. */ - dlPtr2 = (MountPointMap*) ckalloc(sizeof(MountPointMap)); - dlPtr2->volumeName = TclNativeDupInternalRep((ClientData)mountPoint); + dlPtr2 = ckalloc(sizeof(MountPointMap)); + dlPtr2->volumeName = TclNativeDupInternalRep((ClientData) mountPoint); dlPtr2->driveLetter = -1; dlPtr2->nextPtr = driveLetterLookup; - driveLetterLookup = dlPtr2; + driveLetterLookup = dlPtr2; Tcl_MutexUnlock(&mountPointMap); return -1; } @@ -934,39 +501,32 @@ TclWinDriveLetterForVolMountPoint( * * Tcl_WinUtfToTChar, Tcl_WinTCharToUtf -- * - * Convert between UTF-8 and Unicode when running Windows NT or the - * current ANSI code page when running Windows 95. + * Convert between UTF-8 and Unicode when running Windows. * - * On Mac, Unix, and Windows 95, all strings exchanged between Tcl and - * the OS are "char" oriented. We need only one Tcl_Encoding to convert - * between UTF-8 and the system's native encoding. We use NULL to - * represent that encoding. + * On Mac and Unix, all strings exchanged between Tcl and the OS are + * "char" oriented. We need only one Tcl_Encoding to convert between + * UTF-8 and the system's native encoding. We use NULL to represent + * that encoding. * - * On NT, some strings exchanged between Tcl and the OS are "char" + * On Windows, some strings exchanged between Tcl and the OS are "char" * oriented, while others are in Unicode. We need two Tcl_Encoding APIs * depending on whether we are targeting a "char" or Unicode interface. * - * Calling Tcl_UtfToExternal() or Tcl_ExternalToUtf() with an encoding of - * NULL should always used to convert between UTF-8 and the system's + * Calling Tcl_UtfToExternal() or Tcl_ExternalToUtf() with an encoding + * of NULL should always used to convert between UTF-8 and the system's * "char" oriented encoding. The following two functions are used in - * Windows-specific code to convert between UTF-8 and Unicode strings - * (NT) or "char" strings(95). This saves you the trouble of writing the + * Windows-specific code to convert between UTF-8 and Unicode strings. + * This saves you the trouble of writing the * following type of fragment over and over: * - * if (running NT) { - * encoding <- Tcl_GetEncoding("unicode"); - * nativeBuffer <- UtfToExternal(encoding, utfBuffer); - * Tcl_FreeEncoding(encoding); - * } else { - * nativeBuffer <- UtfToExternal(NULL, utfBuffer); - * } - * - * By convention, in Windows a TCHAR is a character in the ANSI code page - * on Windows 95, a Unicode character on Windows NT. If you plan on - * targeting a Unicode interfaces when running on NT and a "char" - * oriented interface while running on 95, these functions should be - * used. If you plan on targetting the same "char" oriented function on - * both 95 and NT, use Tcl_UtfToExternal() with an encoding of NULL. + * encoding <- Tcl_GetEncoding("unicode"); + * nativeBuffer <- UtfToExternal(encoding, utfBuffer); + * Tcl_FreeEncoding(encoding); + * + * By convention, in Windows a TCHAR is a Unicode character. If you plan + * on targeting a Unicode interface when running on Windows, these + * functions should be used. If you plan on targetting a "char" oriented + * function on Windows, use Tcl_UtfToExternal() with an encoding of NULL. * * Results: * The result is a pointer to the string in the desired target encoding. @@ -981,27 +541,125 @@ TclWinDriveLetterForVolMountPoint( TCHAR * Tcl_WinUtfToTChar( - CONST char *string, /* Source string in UTF-8. */ - int len, /* Source string length in bytes, or < 0 for + const char *string, /* Source string in UTF-8. */ + int len, /* Source string length in bytes, or -1 for * strlen(). */ Tcl_DString *dsPtr) /* Uninitialized or free DString in which the * converted string is stored. */ { - return (TCHAR *) Tcl_UtfToExternalDString(tclWinTCharEncoding, - string, len, dsPtr); +#if TCL_UTF_MAX > 4 + Tcl_UniChar ch = 0; + TCHAR *w, *wString; + const char *p, *end; + int oldLength; +#endif + + Tcl_DStringInit(dsPtr); + if (!string) { + return NULL; + } +#if TCL_UTF_MAX > 4 + + if (len < 0) { + len = strlen(string); + } + + /* + * Unicode string length in Tcl_UniChars will be <= UTF-8 string length in + * bytes. + */ + + oldLength = Tcl_DStringLength(dsPtr); + + Tcl_DStringSetLength(dsPtr, + oldLength + (int) ((len + 1) * sizeof(TCHAR))); + wString = (TCHAR *) (Tcl_DStringValue(dsPtr) + oldLength); + + w = wString; + p = string; + end = string + len - 4; + while (p < end) { + p += TclUtfToUniChar(p, &ch); + if (ch > 0xFFFF) { + *w++ = (wchar_t) (0xD800 + ((ch -= 0x10000) >> 10)); + *w++ = (wchar_t) (0xDC00 | (ch & 0x3FF)); + } else { + *w++ = ch; + } + } + end += 4; + while (p < end) { + if (Tcl_UtfCharComplete(p, end-p)) { + p += TclUtfToUniChar(p, &ch); + } else { + ch = UCHAR(*p++); + } + if (ch > 0xFFFF) { + *w++ = (wchar_t) (0xD800 + ((ch -= 0x10000) >> 10)); + *w++ = (wchar_t) (0xDC00 | (ch & 0x3FF)); + } else { + *w++ = ch; + } + } + *w = '\0'; + Tcl_DStringSetLength(dsPtr, + oldLength + ((char *) w - (char *) wString)); + + return wString; +#else + return Tcl_UtfToUniCharDString(string, len, dsPtr); +#endif } char * Tcl_WinTCharToUtf( - CONST TCHAR *string, /* Source string in Unicode when running NT, - * ANSI when running 95. */ - int len, /* Source string length in bytes, or < 0 for + const TCHAR *string, /* Source string in Unicode. */ + int len, /* Source string length in bytes, or -1 for * platform-specific string length. */ Tcl_DString *dsPtr) /* Uninitialized or free DString in which the * converted string is stored. */ { - return Tcl_ExternalToUtfDString(tclWinTCharEncoding, - (CONST char *) string, len, dsPtr); +#if TCL_UTF_MAX > 4 + const TCHAR *w, *wEnd; + char *p, *result; + int oldLength, blen = 1; +#endif + + Tcl_DStringInit(dsPtr); + if (!string) { + return NULL; + } + if (len < 0) { + len = wcslen((TCHAR *)string); + } else { + len /= 2; + } +#if TCL_UTF_MAX > 4 + oldLength = Tcl_DStringLength(dsPtr); + Tcl_DStringSetLength(dsPtr, oldLength + (len + 1) * 4); + result = Tcl_DStringValue(dsPtr) + oldLength; + + p = result; + wEnd = (TCHAR *)string + len; + for (w = (TCHAR *)string; w < wEnd; ) { + if (!blen && ((*w & 0xFC00) != 0xDC00)) { + /* Special case for handling upper surrogates. */ + p += Tcl_UniCharToUtf(-1, p); + } + blen = Tcl_UniCharToUtf(*w, p); + p += blen; + w++; + } + if (!blen) { + /* Special case for handling upper surrogates. */ + p += Tcl_UniCharToUtf(-1, p); + } + Tcl_DStringSetLength(dsPtr, oldLength + (p - result)); + + return result; +#else + return Tcl_UniCharToUtfDString((Tcl_UniChar *)string, len, dsPtr); +#endif } /* @@ -1029,11 +687,16 @@ TclWinCPUID( { int status = TCL_ERROR; -#if defined(__GNUC__) +#if defined(HAVE_INTRIN_H) && defined(_WIN64) + + __cpuid((int *)regsPtr, index); + status = TCL_OK; + +#elif defined(__GNUC__) # if defined(_WIN64) /* * Execute the CPUID instruction with the given index, and store results - * off 'regsPtr'. + * off 'regPtr'. */ __asm__ __volatile__( @@ -1151,7 +814,7 @@ TclWinCPUID( __cpuid(regsPtr, index); status = TCL_OK; -# else +# elif defined (_M_IX86) /* * Define a structure in the stack frame to hold the registers. */ diff --git a/win/tclWinChan.c b/win/tclWinChan.c index a271919..78b510b 100644 --- a/win/tclWinChan.c +++ b/win/tclWinChan.c @@ -83,7 +83,7 @@ static ThreadSpecificData *FileInit(void); static int FileInputProc(ClientData instanceData, char *buf, int toRead, int *errorCode); static int FileOutputProc(ClientData instanceData, - CONST char *buf, int toWrite, int *errorCode); + const char *buf, int toWrite, int *errorCode); static int FileSeekProc(ClientData instanceData, long offset, int mode, int *errorCode); static Tcl_WideInt FileWideSeekProc(ClientData instanceData, @@ -95,12 +95,12 @@ static void FileThreadActionProc(ClientData instanceData, static int FileTruncateProc(ClientData instanceData, Tcl_WideInt length); static DWORD FileGetType(HANDLE handle); -static int NativeIsComPort(CONST TCHAR *nativeName); +static int NativeIsComPort(const TCHAR *nativeName); /* * This structure describes the channel type structure for file based IO. */ -static Tcl_ChannelType fileChannelType = { +static const Tcl_ChannelType fileChannelType = { "file", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ FileCloseProc, /* Close proc. */ @@ -117,7 +117,7 @@ static Tcl_ChannelType fileChannelType = { NULL, /* handler proc. */ FileWideSeekProc, /* Wide seek proc. */ FileThreadActionProc, /* Thread action proc. */ - FileTruncateProc, /* Truncate proc. */ + FileTruncateProc /* Truncate proc. */ }; /* @@ -257,7 +257,7 @@ FileCheckProc( infoPtr = infoPtr->nextPtr) { if (infoPtr->watchMask && !(infoPtr->flags & FILE_PENDING)) { infoPtr->flags |= FILE_PENDING; - evPtr = (FileEvent *) ckalloc(sizeof(FileEvent)); + evPtr = ckalloc(sizeof(FileEvent)); evPtr->header.proc = FileEventProc; evPtr->infoPtr = infoPtr; Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); @@ -340,7 +340,7 @@ FileBlockProc( int mode) /* TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ { - FileInfo *infoPtr = (FileInfo *) instanceData; + FileInfo *infoPtr = instanceData; /* * Files on Windows can not be switched between blocking and nonblocking, @@ -378,7 +378,7 @@ FileCloseProc( ClientData instanceData, /* Pointer to FileInfo structure. */ Tcl_Interp *interp) /* Not used. */ { - FileInfo *fileInfoPtr = (FileInfo *) instanceData; + FileInfo *fileInfoPtr = instanceData; FileInfo *infoPtr; ThreadSpecificData *tsdPtr; int errorCode = 0; @@ -424,7 +424,7 @@ FileCloseProc( break; } } - ckfree((char *)fileInfoPtr); + ckfree(fileInfoPtr); return errorCode; } @@ -453,7 +453,7 @@ FileSeekProc( int mode, /* Relative to where should we seek? */ int *errorCodePtr) /* To store error code. */ { - FileInfo *infoPtr = (FileInfo *) instanceData; + FileInfo *infoPtr = instanceData; LONG newPos, newPosHigh, oldPos, oldPosHigh; DWORD moveMethod; @@ -531,7 +531,7 @@ FileWideSeekProc( int mode, /* Relative to where should we seek? */ int *errorCodePtr) /* To store error code. */ { - FileInfo *infoPtr = (FileInfo *) instanceData; + FileInfo *infoPtr = instanceData; DWORD moveMethod; LONG newPos, newPosHigh; @@ -580,7 +580,7 @@ FileTruncateProc( ClientData instanceData, /* File state. */ Tcl_WideInt length) /* Length to truncate at. */ { - FileInfo *infoPtr = (FileInfo *) instanceData; + FileInfo *infoPtr = instanceData; LONG newPos, newPosHigh, oldPos, oldPosHigh; /* @@ -656,13 +656,16 @@ FileInputProc( int bufSize, /* Num bytes available in buffer. */ int *errorCode) /* Where to store error code. */ { - FileInfo *infoPtr; + FileInfo *infoPtr = instanceData; DWORD bytesRead; *errorCode = 0; - infoPtr = (FileInfo *) instanceData; /* + * TODO: This comment appears to be out of date. We *do* have a + * console driver, over in tclWinConsole.c. After some Windows + * developer confirms, this comment should be revised. + * * Note that we will block on reads from a console buffer until a full * line has been entered. The only way I know of to get around this is to * write a console driver. We should probably do this at some point, but @@ -704,11 +707,11 @@ FileInputProc( static int FileOutputProc( ClientData instanceData, /* File state. */ - CONST char *buf, /* The data buffer. */ + const char *buf, /* The data buffer. */ int toWrite, /* How many bytes to write? */ int *errorCode) /* Where to store error code. */ { - FileInfo *infoPtr = (FileInfo *) instanceData; + FileInfo *infoPtr = instanceData; DWORD bytesWritten; *errorCode = 0; @@ -755,7 +758,7 @@ FileWatchProc( * of TCL_READABLE, TCL_WRITABLE and * TCL_EXCEPTION. */ { - FileInfo *infoPtr = (FileInfo *) instanceData; + FileInfo *infoPtr = instanceData; Tcl_Time blockTime = { 0, 0 }; /* @@ -793,7 +796,7 @@ FileGetHandleProc( int direction, /* TCL_READABLE or TCL_WRITABLE */ ClientData *handlePtr) /* Where to store the handle. */ { - FileInfo *infoPtr = (FileInfo *) instanceData; + FileInfo *infoPtr = instanceData; if (direction & infoPtr->validMask) { *handlePtr = (ClientData) infoPtr->handle; @@ -833,12 +836,12 @@ TclpOpenFileChannel( Tcl_Channel channel = 0; int channelPermissions = 0; DWORD accessMode = 0, createMode, shareMode, flags; - CONST TCHAR *nativeName; + const TCHAR *nativeName; HANDLE handle; char channelName[16 + TCL_INTEGER_SPACE]; TclFile readFile = NULL, writeFile = NULL; - nativeName = (TCHAR*) Tcl_FSGetNativePath(pathPtr); + nativeName = Tcl_FSGetNativePath(pathPtr); if (nativeName == NULL) { if (interp != (Tcl_Interp *) NULL) { Tcl_AppendResult(interp, "couldn't open \"", @@ -929,7 +932,7 @@ TclpOpenFileChannel( flags = FILE_ATTRIBUTE_READONLY; } } else { - flags = (*tclWinProcs->getFileAttributesProc)(nativeName); + flags = GetFileAttributes(nativeName); if (flags == 0xFFFFFFFF) { flags = 0; } @@ -945,8 +948,8 @@ TclpOpenFileChannel( * Now we get to create the file. */ - handle = (*tclWinProcs->createFileProc)(nativeName, accessMode, - shareMode, NULL, createMode, flags, (HANDLE) NULL); + handle = CreateFile(nativeName, accessMode, shareMode, + NULL, createMode, flags, (HANDLE) NULL); if (handle == INVALID_HANDLE_VALUE) { DWORD err = GetLastError(); @@ -956,8 +959,9 @@ TclpOpenFileChannel( } TclWinConvertError(err); if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "couldn't open \"", TclGetString(pathPtr), - "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open \"%s\": %s", + TclGetString(pathPtr), Tcl_PosixError(interp))); } return NULL; } @@ -967,7 +971,7 @@ TclpOpenFileChannel( switch (FileGetType(handle)) { case FILE_TYPE_SERIAL: /* - * Natively named serial ports "com1-9", "\\\\.\\comXX" are + * Natively named serial ports "com1-9", "\\\\.\\comXX" are * already done with the code above. * Here we handle all other serial port names. * @@ -979,9 +983,9 @@ TclpOpenFileChannel( if (handle == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "couldn't reopen serial \"", - TclGetString(pathPtr), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't reopen serial \"%s\": %s", + TclGetString(pathPtr), Tcl_PosixError(interp))); } return NULL; } @@ -1015,8 +1019,11 @@ TclpOpenFileChannel( */ channel = NULL; - Tcl_AppendResult(interp, "couldn't open \"", TclGetString(pathPtr), - "\": bad file type", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open \"%s\": bad file type", + TclGetString(pathPtr))); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "BAD_TYPE", + NULL); break; } @@ -1242,8 +1249,8 @@ TclpGetDefaultStdChannel( Tcl_Channel channel; HANDLE handle; int mode = -1; - char *bufMode = NULL; - DWORD handleId = (DWORD)-1; + const char *bufMode = NULL; + DWORD handleId = (DWORD) -1; /* Standard handle to retrieve. */ switch (type) { @@ -1342,7 +1349,7 @@ TclWinOpenFileChannel( } } - infoPtr = (FileInfo *) ckalloc((unsigned) sizeof(FileInfo)); + infoPtr = ckalloc(sizeof(FileInfo)); /* * TIP #218. Removed the code inserting the new structure into the global @@ -1356,10 +1363,10 @@ TclWinOpenFileChannel( infoPtr->flags = appendMode; infoPtr->handle = handle; infoPtr->dirty = 0; - sprintf(channelName, "file%" TCL_I_MODIFIER "x", (size_t)infoPtr); + sprintf(channelName, "file%" TCL_I_MODIFIER "x", (size_t) infoPtr); infoPtr->channel = Tcl_CreateChannel(&fileChannelType, channelName, - (ClientData) infoPtr, permissions); + infoPtr, permissions); /* * Files have default translation of AUTO and ^Z eof char, which means @@ -1433,7 +1440,7 @@ FileThreadActionProc( int action) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - FileInfo *infoPtr = (FileInfo *) instanceData; + FileInfo *infoPtr = instanceData; if (action == TCL_CHANNEL_THREAD_INSERT) { infoPtr->nextPtr = tsdPtr->firstFilePtr; @@ -1518,12 +1525,11 @@ FileGetType( * NativeIsComPort -- * * Determines if a path refers to a Windows serial port. - * A simple and efficient solution is to use a "name hint" to detect - * COM ports by their filename instead of resorting to a syscall + * A simple and efficient solution is to use a "name hint" to detect + * COM ports by their filename instead of resorting to a syscall * to detect serialness after the fact. * The following patterns cover common serial port names: - * COM[1-9]:? - * //./COM[0-9]+ + * COM[1-9] * \\.\COM[0-9]+ * * Results: @@ -1536,94 +1542,39 @@ static int NativeIsComPort( const TCHAR *nativePath) /* Path of file to access, native encoding. */ { + const WCHAR *p = (const WCHAR *) nativePath; + int i, len = wcslen(p); + /* - * Use wide-char or plain character case-insensitive comparison + * 1. Look for com[1-9]:? */ - if (tclWinProcs->useWide) { - const WCHAR *p = (const WCHAR *) nativePath; - int i, len = wcslen(p); + if ( (len == 4) && (_wcsnicmp(p, L"com", 3) == 0) ) { /* - * 1. Look for com[1-9]:? - */ - - if ( (len >= 4) && (len <= 5) - && (_wcsnicmp(p, L"com", 3) == 0) ) { - /* - * The 4th character must be a digit 1..9 optionally followed by a ":" - */ - - if ( (p[3] < L'1') || (p[3] > L'9') ) { - return 0; - } - if ( (len == 5) && (p[4] != L':') ) { - return 0; - } - return 1; - } - - /* - * 2. Look for //./com[0-9]+ or \\.\com[0-9]+ - */ - - if ( (len >= 8) && ( - (_wcsnicmp(p, L"//./com", 7) == 0) - || (_wcsnicmp(p, L"\\\\.\\com", 7) == 0) ) ) - { - /* - * Charaters 8..end must be a digits 0..9 - */ + * The 4th character must be a digit 1..9 + */ - for ( i=7; i<len; i++ ) { - if ( (p[i] < '0') || (p[i] > '9') ) { - return 0; - } - } - return 1; + if ( (p[3] < L'1') || (p[3] > L'9') ) { + return 0; } + return 1; + } - } else { - const char *p = (const char *) nativePath; - int i, len = strlen(p); + /* + * 2. Look for \\.\com[0-9]+ + */ + if ((len >= 8) && (_wcsnicmp(p, L"\\\\.\\com", 7) == 0)) { /* - * 1. Look for com[1-9]:? - */ - - if ( (len >= 4) && (len <= 5) - && (strnicmp(p, "com", 3) == 0) ) { - /* - * The 4th character must be a digit 1..9 optionally followed by a ":" - */ + * Charaters 8..end must be a digits 0..9 + */ - if ( (p[3] < '1') || (p[3] > '9') ) { + for ( i=7; i<len; i++ ) { + if ( (p[i] < '0') || (p[i] > '9') ) { return 0; } - if ( (len == 5) && (p[4] != ':') ) { - return 0; - } - return 1; - } - - /* - * 2. Look for //./com[0-9]+ or \\.\com[0-9]+ - */ - - if ( (len >= 8) && ( - (strnicmp(p, "//./com", 7) == 0) - || (strnicmp(p, "\\\\.\\com", 7) == 0) ) ) - { - /* - * Charaters 8..end must be a digits 0..9 - */ - - for ( i=7; i<len; i++ ) { - if ( (p[i] < '0') || (p[i] > '9') ) { - return 0; - } - } - return 1; } + return 1; } return 0; } diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c index 361fb3d..d61a030 100644 --- a/win/tclWinConsole.c +++ b/win/tclWinConsole.c @@ -12,9 +12,6 @@ #include "tclWinInt.h" -#include <fcntl.h> -#include <io.h> - /* * The following variable is used to tell whether this module has been * initialized. @@ -48,6 +45,19 @@ 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. */ + TclPipeThreadInfo *TI; /* Thread info structure of writer and reader. */ +} ConsoleThreadInfo; + +/* * This structure describes per-instance data for a console based channel. */ @@ -66,24 +76,16 @@ typedef struct ConsoleInfo { Tcl_ThreadId threadId; /* Thread to which events should be reported. * This value is used by the reader/writer * threads. */ - HANDLE writeThread; /* Handle to writer thread. */ - HANDLE readThread; /* Handle to reader thread. */ - HANDLE writable; /* Manual-reset event to signal when the - * writer thread has finished waiting for the - * current buffer to be written. */ - HANDLE readable; /* Manual-reset event to signal when the - * reader thread has finished waiting for - * input. */ - HANDLE startWriter; /* Auto-reset event used by the main thread to - * signal when the writer thread should - * attempt to write to the console. */ - HANDLE stopWriter; /* Auto-reset event used by the main thread to - * signal when the writer thread should exit */ - HANDLE startReader; /* Auto-reset event used by the main thread to - * signal when the reader thread should - * attempt to read from the console. */ - HANDLE stopReader; /* Auto-reset event used by the main thread to - * signal when the reader thread should exit */ + ConsoleThreadInfo writer; /* A specialized thread for handling + * asynchronous writes to the console; the + * waiting starts when a control event is sent, + * and a reset event is sent back to the main + * thread when the write is done. */ + ConsoleThreadInfo reader; /* A specialized thread for handling + * asynchronous reads from the console; the + * waiting starts when a control event is sent, + * and a reset event is sent back to the main + * thread when input is available. */ DWORD writeError; /* An error caused by the last background * write. Set to 0 if no error has been * detected. This word is shared with the @@ -98,8 +100,8 @@ typedef struct ConsoleInfo { int readFlags; /* Flags that are shared with the reader * thread. Access is synchronized with the * readable object. */ - int bytesRead; /* number of bytes in the buffer */ - int offset; /* number of bytes read out of the buffer */ + int bytesRead; /* Number of bytes in the buffer. */ + int offset; /* Number of bytes read out of the buffer. */ char buffer[CONSOLE_BUFFER_SIZE]; /* Data consumed by reader thread. */ } ConsoleInfo; @@ -133,7 +135,8 @@ typedef struct ConsoleEvent { * Declarations for functions used only in this file. */ -static int ConsoleBlockModeProc(ClientData instanceData,int mode); +static int ConsoleBlockModeProc(ClientData instanceData, + int mode); static void ConsoleCheckProc(ClientData clientData, int flags); static int ConsoleCloseProc(ClientData instanceData, Tcl_Interp *interp); @@ -145,7 +148,7 @@ static void ConsoleInit(void); static int ConsoleInputProc(ClientData instanceData, char *buf, int toRead, int *errorCode); static int ConsoleOutputProc(ClientData instanceData, - CONST char *buf, int toWrite, int *errorCode); + const char *buf, int toWrite, int *errorCode); static DWORD WINAPI ConsoleReaderThread(LPVOID arg); static void ConsoleSetupProc(ClientData clientData, int flags); static void ConsoleWatchProc(ClientData instanceData, int mask); @@ -154,13 +157,18 @@ 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); /* * This structure describes the channel type structure for command console * based IO. */ -static Tcl_ChannelType consoleChannelType = { +static const Tcl_ChannelType consoleChannelType = { "console", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ ConsoleCloseProc, /* Close proc. */ @@ -172,23 +180,27 @@ static Tcl_ChannelType consoleChannelType = { ConsoleWatchProc, /* Set up notifier to watch the channel. */ ConsoleGetHandleProc, /* Get an OS handle from channel. */ NULL, /* close2proc. */ - ConsoleBlockModeProc, /* Set blocking or non-blocking mode.*/ - NULL, /* flush proc. */ - NULL, /* handler proc. */ - NULL, /* wide seek proc */ - ConsoleThreadActionProc, /* thread action proc */ - NULL, /* truncation */ + ConsoleBlockModeProc, /* Set blocking or non-blocking mode. */ + NULL, /* Flush proc. */ + NULL, /* Handler proc. */ + NULL, /* Wide seek proc. */ + ConsoleThreadActionProc, /* Thread action proc. */ + NULL /* Truncation proc. */ }; /* *---------------------------------------------------------------------- * - * readConsoleBytes, writeConsoleBytes -- - * Wrapper for ReadConsole{A,W}, that takes and returns number of bytes - * instead of number of TCHARS + * ReadConsoleBytes, WriteConsoleBytes -- + * + * Wrapper for ReadConsole{A,W}, that takes and returns number of bytes + * instead of number of TCHARS. + * + *---------------------------------------------------------------------- */ + static BOOL -readConsoleBytes( +ReadConsoleBytes( HANDLE hConsole, LPVOID lpBuffer, DWORD nbytes, @@ -196,30 +208,44 @@ readConsoleBytes( { DWORD ntchars; BOOL result; - int tcharsize; - tcharsize = tclWinProcs->useWide? 2 : 1; - result = tclWinProcs->readConsoleProc( - hConsole, lpBuffer, nbytes / tcharsize, &ntchars, NULL); - if (nbytesread) - *nbytesread = (ntchars*tcharsize); + int tcharsize = sizeof(TCHAR); + + /* + * If user types a Ctrl-Break or Ctrl-C, ReadConsole will return + * success with ntchars == 0 and GetLastError() will be + * ERROR_OPERATION_ABORTED. We do not want to treat this case + * as EOF so we will loop around again. If no Ctrl signal handlers + * have been established, the default signal OS handler in a separate + * thread will terminate the program. If a Ctrl signal handler + * has been established (through an extension for example), it + * will run and take whatever action it deems appropriate. + */ + do { + result = ReadConsole(hConsole, lpBuffer, nbytes / tcharsize, &ntchars, + NULL); + } while (result && ntchars == 0 && GetLastError() == ERROR_OPERATION_ABORTED); + if (nbytesread != NULL) { + *nbytesread = ntchars * tcharsize; + } return result; } static BOOL -writeConsoleBytes( +WriteConsoleBytes( HANDLE hConsole, - const VOID *lpBuffer, + const void *lpBuffer, DWORD nbytes, LPDWORD nbyteswritten) { DWORD ntchars; BOOL result; - int tcharsize; - tcharsize = tclWinProcs->useWide? 2 : 1; - result = tclWinProcs->writeConsoleProc( - hConsole, lpBuffer, nbytes / tcharsize, &ntchars, NULL); - if (nbyteswritten) - *nbyteswritten = (ntchars*tcharsize); + int tcharsize = sizeof(TCHAR); + + result = WriteConsole(hConsole, lpBuffer, nbytes / tcharsize, &ntchars, + NULL); + if (nbyteswritten != NULL) { + *nbyteswritten = ntchars * tcharsize; + } return result; } @@ -242,8 +268,6 @@ writeConsoleBytes( static void ConsoleInit(void) { - ThreadSpecificData *tsdPtr; - /* * Check the initialized flag first, then check again in the mutex. This * is a speed enhancement. @@ -258,9 +282,9 @@ ConsoleInit(void) Tcl_MutexUnlock(&consoleMutex); } - tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); - if (tsdPtr == NULL) { - tsdPtr = TCL_TSD_INIT(&dataKey); + if (TclThreadDataKeyGet(&dataKey) == NULL) { + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + tsdPtr->firstConsolePtr = NULL; Tcl_CreateEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL); Tcl_CreateThreadExitHandler(ConsoleExitHandler, NULL); @@ -286,7 +310,7 @@ ConsoleInit(void) static void ConsoleExitHandler( - ClientData clientData) /* Old window proc */ + ClientData clientData) /* Old window proc. */ { Tcl_DeleteEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL); } @@ -310,7 +334,7 @@ ConsoleExitHandler( static void ProcExitHandler( - ClientData clientData) /* Old window proc */ + ClientData clientData) /* Old window proc. */ { Tcl_MutexLock(&consoleMutex); initialized = 0; @@ -355,7 +379,8 @@ ConsoleSetupProc( for (infoPtr = tsdPtr->firstConsolePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (infoPtr->watchMask & TCL_WRITABLE) { - if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) { + if (WaitForSingleObject(infoPtr->writer.readyEvent, + 0) != WAIT_TIMEOUT) { block = 0; } } @@ -393,7 +418,6 @@ ConsoleCheckProc( int flags) /* Event flags as passed to Tcl_DoOneEvent. */ { ConsoleInfo *infoPtr; - ConsoleEvent *evPtr; int needEvent; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -418,7 +442,8 @@ ConsoleCheckProc( needEvent = 0; if (infoPtr->watchMask & TCL_WRITABLE) { - if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) { + if (WaitForSingleObject(infoPtr->writer.readyEvent, + 0) != WAIT_TIMEOUT) { needEvent = 1; } } @@ -430,8 +455,9 @@ ConsoleCheckProc( } if (needEvent) { + ConsoleEvent *evPtr = ckalloc(sizeof(ConsoleEvent)); + infoPtr->flags |= CONSOLE_PENDING; - evPtr = (ConsoleEvent *) ckalloc(sizeof(ConsoleEvent)); evPtr->header.proc = ConsoleEventProc; evPtr->infoPtr = infoPtr; Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); @@ -439,7 +465,6 @@ ConsoleCheckProc( } } - /* *---------------------------------------------------------------------- * @@ -462,7 +487,7 @@ ConsoleBlockModeProc( int mode) /* TCL_MODE_BLOCKING or * TCL_MODE_NONBLOCKING. */ { - ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData; + ConsoleInfo *infoPtr = instanceData; /* * Consoles on Windows can not be switched between blocking and @@ -475,7 +500,7 @@ ConsoleBlockModeProc( if (mode == TCL_MODE_NONBLOCKING) { infoPtr->flags |= CONSOLE_ASYNC; } else { - infoPtr->flags &= ~(CONSOLE_ASYNC); + infoPtr->flags &= ~CONSOLE_ASYNC; } return 0; } @@ -501,13 +526,10 @@ ConsoleCloseProc( ClientData instanceData, /* Pointer to ConsoleInfo structure. */ Tcl_Interp *interp) /* For error reporting. */ { - ConsoleInfo *consolePtr = (ConsoleInfo *) instanceData; - int errorCode; + ConsoleInfo *consolePtr = instanceData; + int errorCode = 0; ConsoleInfo *infoPtr, **nextPtrPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - DWORD exitCode; - - errorCode = 0; /* * Clean up the background thread if necessary. Note that this must be @@ -515,49 +537,11 @@ ConsoleCloseProc( * trying to read from the console. */ - if (consolePtr->readThread) { - /* - * The thread may already have closed on it's own. Check it's exit - * code. - */ - - GetExitCodeThread(consolePtr->readThread, &exitCode); - - if (exitCode == STILL_ACTIVE) { - /* - * Set the stop event so that if the reader thread is blocked in - * ConsoleReaderThread on WaitForMultipleEvents, it will exit - * cleanly. - */ - - SetEvent(consolePtr->stopReader); - - /* - * Wait at most 20 milliseconds for the reader thread to close. - */ - - if (WaitForSingleObject(consolePtr->readThread, 20) - == WAIT_TIMEOUT) { - /* - * Forcibly terminate the background thread as a last resort. - * Note that we need to guard against terminating the thread - * while it is in the middle of Tcl_ThreadAlert because it - * won't be able to release the notifier lock. - */ - - Tcl_MutexLock(&consoleMutex); - - /* BUG: this leaks memory. */ - TerminateThread(consolePtr->readThread, 0); - Tcl_MutexUnlock(&consoleMutex); - } - } - - CloseHandle(consolePtr->readThread); - CloseHandle(consolePtr->readable); - CloseHandle(consolePtr->startReader); - CloseHandle(consolePtr->stopReader); - consolePtr->readThread = NULL; + if (consolePtr->reader.thread) { + TclPipeThreadStop(&consolePtr->reader.TI, consolePtr->reader.thread); + CloseHandle(consolePtr->reader.thread); + CloseHandle(consolePtr->reader.readyEvent); + consolePtr->reader.thread = NULL; } consolePtr->validMask &= ~TCL_READABLE; @@ -567,62 +551,23 @@ ConsoleCloseProc( * should be no pending write operations. */ - if (consolePtr->writeThread) { + if (consolePtr->writer.thread) { if (consolePtr->toWrite) { /* * We only need to wait if there is something to write. This may - * prevent infinite wait on exit. [python bug 216289] + * prevent infinite wait on exit. [Python Bug 216289] */ - WaitForSingleObject(consolePtr->writable, INFINITE); + WaitForSingleObject(consolePtr->writer.readyEvent, 5000); } - /* - * 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. - */ - - 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); - } - } - - CloseHandle(consolePtr->writeThread); - CloseHandle(consolePtr->writable); - CloseHandle(consolePtr->startWriter); - CloseHandle(consolePtr->stopWriter); - consolePtr->writeThread = NULL; + TclPipeThreadStop(&consolePtr->writer.TI, consolePtr->writer.thread); + CloseHandle(consolePtr->writer.thread); + CloseHandle(consolePtr->writer.readyEvent); + consolePtr->writer.thread = 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 @@ -648,7 +593,7 @@ ConsoleCloseProc( for (nextPtrPtr = &(tsdPtr->firstConsolePtr), infoPtr = *nextPtrPtr; infoPtr != NULL; nextPtrPtr = &infoPtr->nextPtr, infoPtr = *nextPtrPtr) { - if (infoPtr == (ConsoleInfo *)consolePtr) { + if (infoPtr == (ConsoleInfo *) consolePtr) { *nextPtrPtr = infoPtr->nextPtr; break; } @@ -657,7 +602,7 @@ ConsoleCloseProc( ckfree(consolePtr->writeBuf); consolePtr->writeBuf = 0; } - ckfree((char*) consolePtr); + ckfree(consolePtr); return errorCode; } @@ -688,7 +633,7 @@ ConsoleInputProc( * buffer? */ int *errorCode) /* Where to store error code. */ { - ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData; + ConsoleInfo *infoPtr = instanceData; DWORD count, bytesRead = 0; int result; @@ -723,7 +668,7 @@ ConsoleInputProc( bytesRead = infoPtr->bytesRead - infoPtr->offset; /* - * Reset the buffer + * Reset the buffer. */ infoPtr->readFlags &= ~CONSOLE_BUFFERED; @@ -739,8 +684,15 @@ ConsoleInputProc( * byte is available or an EOF occurs. */ - if (readConsoleBytes(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize, &count) - == TRUE) { + if (ReadConsoleBytes(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize, + &count) == TRUE) { + /* + * TODO: This potentially writes beyond the limits specified + * by the caller. In practice this is harmless, since all writes + * are into ChannelBuffers, and those have padding, but still + * ought to remove this, unless some Windows wizard can give + * a reason not to. + */ buf[count] = '\0'; return count; } @@ -769,22 +721,26 @@ ConsoleInputProc( static int ConsoleOutputProc( ClientData instanceData, /* Console state. */ - CONST char *buf, /* The data buffer. */ + const char *buf, /* The data buffer. */ int toWrite, /* How many bytes to write? */ int *errorCode) /* Where to store error code. */ { - ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData; + ConsoleInfo *infoPtr = instanceData; + ConsoleThreadInfo *threadInfo = &infoPtr->writer; DWORD bytesWritten, timeout; *errorCode = 0; - timeout = (infoPtr->flags & CONSOLE_ASYNC) ? 0 : INFINITE; - if (WaitForSingleObject(infoPtr->writable, timeout) == WAIT_TIMEOUT) { + + /* avoid blocking if pipe-thread exited */ + timeout = (infoPtr->flags & CONSOLE_ASYNC) || !TclPipeThreadIsAlive(&threadInfo->TI) + || TclInExit() || TclInThreadExit() ? 0 : INFINITE; + if (WaitForSingleObject(threadInfo->readyEvent, timeout) == WAIT_TIMEOUT) { /* * The writer thread is blocked waiting for a write to complete and * the channel is in non-blocking mode. */ - errno = EAGAIN; + errno = EWOULDBLOCK; goto error; } @@ -813,12 +769,12 @@ ConsoleOutputProc( ckfree(infoPtr->writeBuf); } infoPtr->writeBufLen = toWrite; - infoPtr->writeBuf = ckalloc((size_t)toWrite); + infoPtr->writeBuf = ckalloc(toWrite); } - memcpy(infoPtr->writeBuf, buf, (size_t)toWrite); + memcpy(infoPtr->writeBuf, buf, (size_t) toWrite); infoPtr->toWrite = toWrite; - ResetEvent(infoPtr->writable); - SetEvent(infoPtr->startWriter); + ResetEvent(threadInfo->readyEvent); + TclPipeThreadSignal(&threadInfo->TI); bytesWritten = toWrite; } else { /* @@ -826,9 +782,8 @@ ConsoleOutputProc( * avoids an unnecessary copy. */ - if (writeConsoleBytes(infoPtr->handle, buf, (DWORD)toWrite, - &bytesWritten) - == FALSE) { + if (WriteConsoleBytes(infoPtr->handle, buf, (DWORD) toWrite, + &bytesWritten) == FALSE) { TclWinConvertError(GetLastError()); goto error; } @@ -867,7 +822,7 @@ ConsoleEventProc( int flags) /* Flags that indicate what events to handle, * such as TCL_FILE_EVENTS. */ { - ConsoleEvent *consoleEvPtr = (ConsoleEvent *)evPtr; + ConsoleEvent *consoleEvPtr = (ConsoleEvent *) evPtr; ConsoleInfo *infoPtr; int mask; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -886,7 +841,7 @@ ConsoleEventProc( for (infoPtr = tsdPtr->firstConsolePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (consoleEvPtr->infoPtr == infoPtr) { - infoPtr->flags &= ~(CONSOLE_PENDING); + infoPtr->flags &= ~CONSOLE_PENDING; break; } } @@ -907,7 +862,8 @@ ConsoleEventProc( mask = 0; if (infoPtr->watchMask & TCL_WRITABLE) { - if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) { + if (WaitForSingleObject(infoPtr->writer.readyEvent, + 0) != WAIT_TIMEOUT) { mask = TCL_WRITABLE; } } @@ -954,7 +910,7 @@ ConsoleWatchProc( * TCL_EXCEPTION. */ { ConsoleInfo **nextPtrPtr, *ptr; - ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData; + ConsoleInfo *infoPtr = instanceData; int oldMask = infoPtr->watchMask; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -966,6 +922,7 @@ ConsoleWatchProc( infoPtr->watchMask = mask & infoPtr->validMask; if (infoPtr->watchMask) { Tcl_Time blockTime = { 0, 0 }; + if (!oldMask) { infoPtr->nextPtr = tsdPtr->firstConsolePtr; tsdPtr->firstConsolePtr = infoPtr; @@ -1008,12 +965,12 @@ ConsoleWatchProc( static int ConsoleGetHandleProc( ClientData instanceData, /* The console state. */ - int direction, /* TCL_READABLE or TCL_WRITABLE */ + int direction, /* TCL_READABLE or TCL_WRITABLE. */ ClientData *handlePtr) /* Where to store the handle. */ { - ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData; + ConsoleInfo *infoPtr = instanceData; - *handlePtr = (ClientData) infoPtr->handle; + *handlePtr = infoPtr->handle; return TCL_OK; } @@ -1046,6 +1003,7 @@ WaitForRead( { DWORD timeout, count; HANDLE *handle = infoPtr->handle; + ConsoleThreadInfo *threadInfo = &infoPtr->reader; INPUT_RECORD input; while (1) { @@ -1053,14 +1011,16 @@ WaitForRead( * Synchronize with the reader thread. */ - timeout = blocking ? INFINITE : 0; - if (WaitForSingleObject(infoPtr->readable, timeout) == WAIT_TIMEOUT) { + /* avoid blocking if pipe-thread exited */ + timeout = (!blocking || !TclPipeThreadIsAlive(&threadInfo->TI) + || TclInExit() || TclInThreadExit()) ? 0 : INFINITE; + if (WaitForSingleObject(threadInfo->readyEvent, timeout) == WAIT_TIMEOUT) { /* * The reader thread is blocked waiting for data and the channel * is in non-blocking mode. */ - errno = EAGAIN; + errno = EWOULDBLOCK; return -1; } @@ -1113,8 +1073,8 @@ WaitForRead( * There wasn't any data available, so reset the thread and try again. */ - ResetEvent(infoPtr->readable); - SetEvent(infoPtr->startReader); + ResetEvent(threadInfo->readyEvent); + TclPipeThreadSignal(&threadInfo->TI); } } @@ -1141,37 +1101,34 @@ static DWORD WINAPI ConsoleReaderThread( LPVOID arg) { - ConsoleInfo *infoPtr = (ConsoleInfo *)arg; - HANDLE *handle = infoPtr->handle; - DWORD waitResult; - HANDLE wEvents[2]; - - /* The first event takes precedence. */ - wEvents[0] = infoPtr->stopReader; - wEvents[1] = infoPtr->startReader; + TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *)arg; + ConsoleInfo *infoPtr = NULL; /* access info only after success init/wait */ + HANDLE *handle = NULL; + ConsoleThreadInfo *threadInfo = NULL; + int done = 0; - for (;;) { + while (!done) { /* - * Wait for the main thread to signal before attempting to wait. + * Wait for the main thread to signal before attempting to read. */ - waitResult = WaitForMultipleObjects(2, wEvents, FALSE, INFINITE); - - if (waitResult != (WAIT_OBJECT_0 + 1)) { - /* - * The start event was not signaled. It must be the stop event or - * an error, so exit this thread. - */ - + if (!TclPipeThreadWaitForSignal(&pipeTI)) { + /* exit */ break; } + if (!infoPtr) { + infoPtr = (ConsoleInfo *)pipeTI->clientData; + handle = infoPtr->handle; + threadInfo = &infoPtr->reader; + } + /* * Look for data on the console, but first ignore any events that are * not KEY_EVENTs. */ - if (readConsoleBytes(handle, infoPtr->buffer, CONSOLE_BUFFER_SIZE, + if (ReadConsoleBytes(handle, infoPtr->buffer, CONSOLE_BUFFER_SIZE, (LPDWORD) &infoPtr->bytesRead) != FALSE) { /* * Data was stored in the buffer. @@ -1179,12 +1136,12 @@ ConsoleReaderThread( infoPtr->readFlags |= CONSOLE_BUFFERED; } else { - DWORD err; - err = GetLastError(); + DWORD err = GetLastError(); - if (err == (DWORD)EOF) { + if (err == (DWORD) EOF) { infoPtr->readFlags = CONSOLE_EOF; } + done = 1; } /* @@ -1192,7 +1149,7 @@ ConsoleReaderThread( * waking up the notifier thread. */ - SetEvent(infoPtr->readable); + SetEvent(threadInfo->readyEvent); /* * Alert the foreground thread. Note that we need to treat this like a @@ -1206,11 +1163,15 @@ ConsoleReaderThread( * TIP #218. When in flight ignore the event, no one will receive * it anyway. */ + Tcl_ThreadAlert(infoPtr->threadId); } Tcl_MutexUnlock(&consoleMutex); } + /* Worker exit, so inform the main thread or free TI-structure (if owned) */ + TclPipeThreadExit(&pipeTI); + return 0; } @@ -1237,32 +1198,27 @@ static DWORD WINAPI ConsoleWriterThread( LPVOID arg) { - - ConsoleInfo *infoPtr = (ConsoleInfo *)arg; - HANDLE *handle = infoPtr->handle; - DWORD count, toWrite, waitResult; + TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *)arg; + ConsoleInfo *infoPtr = NULL; /* access info only after success init/wait */ + HANDLE *handle = NULL; + ConsoleThreadInfo *threadInfo = NULL; + DWORD count, toWrite; char *buf; - HANDLE wEvents[2]; + int done = 0; - /* The first event takes precedence. */ - wEvents[0] = infoPtr->stopWriter; - wEvents[1] = infoPtr->startWriter; - - for (;;) { + while (!done) { /* * Wait for the main thread to signal before attempting to write. */ - - waitResult = WaitForMultipleObjects(2, wEvents, FALSE, INFINITE); - - if (waitResult != (WAIT_OBJECT_0 + 1)) { - /* - * The start event was not signaled. It must be the stop event or - * an error, so exit this thread. - */ - + if (!TclPipeThreadWaitForSignal(&pipeTI)) { + /* exit */ break; } + if (!infoPtr) { + infoPtr = (ConsoleInfo *)pipeTI->clientData; + handle = infoPtr->handle; + threadInfo = &infoPtr->writer; + } buf = infoPtr->writeBuf; toWrite = infoPtr->toWrite; @@ -1272,14 +1228,14 @@ ConsoleWriterThread( */ while (toWrite > 0) { - if (writeConsoleBytes(handle, buf, (DWORD)toWrite, - &count) == FALSE) { + if (WriteConsoleBytes(handle, buf, (DWORD) toWrite, + &count) == FALSE) { infoPtr->writeError = GetLastError(); + done = 1; break; - } else { - toWrite -= count; - buf += count; } + toWrite -= count; + buf += count; } /* @@ -1287,7 +1243,7 @@ ConsoleWriterThread( * waking up the notifier thread. */ - SetEvent(infoPtr->writable); + SetEvent(threadInfo->readyEvent); /* * Alert the foreground thread. Note that we need to treat this like a @@ -1307,6 +1263,9 @@ ConsoleWriterThread( Tcl_MutexUnlock(&consoleMutex); } + /* Worker exit, so inform the main thread or free TI-structure (if owned) */ + TclPipeThreadExit(&pipeTI); + return 0; } @@ -1323,7 +1282,7 @@ ConsoleWriterThread( * Returns the new channel, or NULL. * * Side effects: - * May open the channel + * May open the channel. * *---------------------------------------------------------------------- */ @@ -1336,7 +1295,7 @@ TclWinOpenConsoleChannel( { char encoding[4 + TCL_INTEGER_SPACE]; ConsoleInfo *infoPtr; - DWORD id, modes; + DWORD modes; ConsoleInit(); @@ -1344,7 +1303,7 @@ TclWinOpenConsoleChannel( * See if a channel with this handle already exists. */ - infoPtr = (ConsoleInfo *) ckalloc((unsigned) sizeof(ConsoleInfo)); + infoPtr = ckalloc(sizeof(ConsoleInfo)); memset(infoPtr, 0, sizeof(ConsoleInfo)); infoPtr->validMask = permissions; @@ -1361,10 +1320,10 @@ TclWinOpenConsoleChannel( * for instance). */ - sprintf(channelName, "file%" TCL_I_MODIFIER "x", (size_t)infoPtr); + sprintf(channelName, "file%" TCL_I_MODIFIER "x", (size_t) infoPtr); infoPtr->channel = Tcl_CreateChannel(&consoleChannelType, channelName, - (ClientData) infoPtr, permissions); + infoPtr, permissions); if (permissions & TCL_READABLE) { /* @@ -1378,21 +1337,20 @@ TclWinOpenConsoleChannel( modes |= ENABLE_LINE_INPUT; SetConsoleMode(infoPtr->handle, modes); - infoPtr->readable = CreateEvent(NULL, TRUE, TRUE, NULL); - infoPtr->startReader = CreateEvent(NULL, FALSE, FALSE, NULL); - infoPtr->stopReader = CreateEvent(NULL, FALSE, FALSE, NULL); - infoPtr->readThread = CreateThread(NULL, 256, ConsoleReaderThread, - infoPtr, 0, &id); - SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST); + infoPtr->reader.readyEvent = CreateEvent(NULL, TRUE, TRUE, NULL); + infoPtr->reader.thread = CreateThread(NULL, 256, ConsoleReaderThread, + TclPipeThreadCreateTI(&infoPtr->reader.TI, infoPtr, + infoPtr->reader.readyEvent), 0, NULL); + SetThreadPriority(infoPtr->reader.thread, THREAD_PRIORITY_HIGHEST); } if (permissions & TCL_WRITABLE) { - infoPtr->writable = CreateEvent(NULL, TRUE, TRUE, NULL); - infoPtr->startWriter = CreateEvent(NULL, FALSE, FALSE, NULL); - infoPtr->stopWriter = CreateEvent(NULL, FALSE, FALSE, NULL); - infoPtr->writeThread = CreateThread(NULL, 256, ConsoleWriterThread, - infoPtr, 0, &id); - SetThreadPriority(infoPtr->writeThread, THREAD_PRIORITY_HIGHEST); + + infoPtr->writer.readyEvent = CreateEvent(NULL, TRUE, TRUE, NULL); + infoPtr->writer.thread = CreateThread(NULL, 256, ConsoleWriterThread, + TclPipeThreadCreateTI(&infoPtr->writer.TI, infoPtr, + infoPtr->writer.readyEvent), 0, NULL); + SetThreadPriority(infoPtr->writer.thread, THREAD_PRIORITY_HIGHEST); } /* @@ -1402,11 +1360,11 @@ TclWinOpenConsoleChannel( Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto"); Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}"); - if (tclWinProcs->useWide) - Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", "unicode"); - else - Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", encoding); - +#ifdef UNICODE + Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", "unicode"); +#else + Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", encoding); +#endif return infoPtr->channel; } @@ -1431,9 +1389,10 @@ ConsoleThreadActionProc( ClientData instanceData, int action) { - ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData; + ConsoleInfo *infoPtr = instanceData; - /* We do not access firstConsolePtr in the thread structures. This is not + /* + * We do not access firstConsolePtr in the thread structures. This is not * for all serials managed by the thread, but only those we are watching. * Removal of the filevent handlers before transfer thus takes care of * this structure. diff --git a/win/tclWinError.c b/win/tclWinError.c index c569d61..fea4b0f 100644 --- a/win/tclWinError.c +++ b/win/tclWinError.c @@ -11,13 +11,11 @@ */ #include "tclInt.h" -#include "tclPort.h" - /* * The following table contains the mapping from Win32 errors to errno errors. */ -static CONST unsigned char errorTable[] = { +static const unsigned char errorTable[] = { 0, EINVAL, /* ERROR_INVALID_FUNCTION 1 */ ENOENT, /* ERROR_FILE_NOT_FOUND 2 */ @@ -293,7 +291,7 @@ static CONST unsigned char errorTable[] = { * errno errors. */ -static CONST int wsaErrorTable[] = { +static const unsigned char wsaErrorTable[] = { EWOULDBLOCK, /* WSAEWOULDBLOCK */ EINPROGRESS, /* WSAEINPROGRESS */ EALREADY, /* WSAEALREADY */ @@ -364,39 +362,62 @@ TclWinConvertError( Tcl_SetErrno(errorTable[errCode]); } } - + +#ifdef __CYGWIN__ /* *---------------------------------------------------------------------- * - * TclWinConvertWSAError -- + * tclWinDebugPanic -- * - * This routine converts a WinSock error into an errno value. + * Display a message. If a debugger is present, present it directly to + * the debugger, otherwise send it to stderr. * * Results: * None. * * Side effects: - * Sets the errno global variable. + * None. * *---------------------------------------------------------------------- */ -void -TclWinConvertWSAError( - DWORD errCode) /* Win32 error code. */ +TCL_NORETURN void +tclWinDebugPanic( + const char *format, ...) { - if (errCode >= sizeof(errorTable)/sizeof(errorTable[0])) { - errCode -= WSAEWOULDBLOCK; - if (errCode >= sizeof(wsaErrorTable)/sizeof(wsaErrorTable[0])) { - Tcl_SetErrno(errorTable[1]); - } else { - Tcl_SetErrno(wsaErrorTable[errCode]); +#define TCL_MAX_WARN_LEN 1024 + va_list argList; + va_start(argList, format); + + if (IsDebuggerPresent()) { + WCHAR msgString[TCL_MAX_WARN_LEN]; + char buf[TCL_MAX_WARN_LEN * TCL_UTF_MAX]; + + vsnprintf(buf, sizeof(buf), format, argList); + msgString[TCL_MAX_WARN_LEN-1] = L'\0'; + MultiByteToWideChar(CP_UTF8, 0, buf, -1, msgString, TCL_MAX_WARN_LEN); + + /* + * Truncate MessageBox string if it is too long to not overflow the buffer. + */ + + if (msgString[TCL_MAX_WARN_LEN-1] != L'\0') { + memcpy(msgString + (TCL_MAX_WARN_LEN - 5), L" ...", 5 * sizeof(WCHAR)); } + OutputDebugStringW(msgString); } else { - Tcl_SetErrno(errorTable[errCode]); + vfprintf(stderr, format, argList); + fprintf(stderr, "\n"); + fflush(stderr); } +# if defined(__GNUC__) + __builtin_trap(); +# else + DebugBreak(); +# endif + abort(); } - +#endif /* * Local Variables: * mode: c diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index 441337e..2f28154 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -54,12 +54,12 @@ static const int attributeArray[] = {FILE_ATTRIBUTE_ARCHIVE, FILE_ATTRIBUTE_HIDD 0, FILE_ATTRIBUTE_READONLY, 0, FILE_ATTRIBUTE_SYSTEM}; -CONST char *tclpFileAttrStrings[] = { +const char *const tclpFileAttrStrings[] = { "-archive", "-hidden", "-longname", "-readonly", "-shortname", "-system", (char *) NULL }; -CONST TclFileAttrProcs tclpFileAttrProcs[] = { +const TclFileAttrProcs tclpFileAttrProcs[] = { {GetWinFileAttributes, SetWinFileAttributes}, {GetWinFileAttributes, SetWinFileAttributes}, {GetWinFileLongName, CannotSetAttribute}, @@ -71,7 +71,7 @@ CONST TclFileAttrProcs tclpFileAttrProcs[] = { * Prototype for the TraverseWinTree callback function. */ -typedef int (TraversalProc)(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr, +typedef int (TraversalProc)(const TCHAR *srcPtr, const TCHAR *dstPtr, int type, Tcl_DString *errorPtr); /* @@ -82,18 +82,18 @@ static void StatError(Tcl_Interp *interp, Tcl_Obj *fileName); static int ConvertFileNameFormat(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, int longShort, Tcl_Obj **attributePtrPtr); -static int DoCopyFile(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr); -static int DoCreateDirectory(CONST TCHAR *pathPtr); -static int DoRemoveJustDirectory(CONST TCHAR *nativeSrc, +static int DoCopyFile(const TCHAR *srcPtr, const TCHAR *dstPtr); +static int DoCreateDirectory(const TCHAR *pathPtr); +static int DoRemoveJustDirectory(const TCHAR *nativeSrc, int ignoreError, Tcl_DString *errorPtr); static int DoRemoveDirectory(Tcl_DString *pathPtr, int recursive, Tcl_DString *errorPtr); -static int DoRenameFile(CONST TCHAR *nativeSrc, - CONST TCHAR *dstPtr); -static int TraversalCopy(CONST TCHAR *srcPtr, CONST TCHAR *dstPtr, +static int DoRenameFile(const TCHAR *nativeSrc, + const TCHAR *dstPtr); +static int TraversalCopy(const TCHAR *srcPtr, const TCHAR *dstPtr, int type, Tcl_DString *errorPtr); -static int TraversalDelete(CONST TCHAR *srcPtr, - CONST TCHAR *dstPtr, int type, +static int TraversalDelete(const TCHAR *srcPtr, + const TCHAR *dstPtr, int type, Tcl_DString *errorPtr); static int TraverseWinTree(TraversalProc *traverseProc, Tcl_DString *sourcePtr, Tcl_DString *dstPtr, @@ -151,9 +151,9 @@ TclpObjRenameFile( static int DoRenameFile( - CONST TCHAR *nativeSrc, /* Pathname of file or dir to be renamed + const TCHAR *nativeSrc, /* Pathname of file or dir to be renamed * (native). */ - CONST TCHAR *nativeDst) /* New pathname for file or directory + const TCHAR *nativeDst) /* New pathname for file or directory * (native). */ { #if defined(HAVE_NO_SEH) && !defined(_WIN64) @@ -256,7 +256,7 @@ DoRenameFile( [registration] "m" (registration), [nativeDst] "m" (nativeDst), [nativeSrc] "m" (nativeSrc), - [moveFile] "r" (tclWinProcs->moveFileProc) + [moveFile] "r" (MoveFile) : "%eax", "%ebx", "%ecx", "%edx", "memory" ); @@ -267,7 +267,7 @@ DoRenameFile( #ifndef HAVE_NO_SEH __try { #endif - if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) { + if ((*MoveFile)(nativeSrc, nativeDst) != FALSE) { retval = TCL_OK; } #ifndef HAVE_NO_SEH @@ -281,10 +281,10 @@ DoRenameFile( TclWinConvertError(GetLastError()); - srcAttr = (*tclWinProcs->getFileAttributesProc)(nativeSrc); - dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst); + srcAttr = GetFileAttributes(nativeSrc); + dstAttr = GetFileAttributes(nativeDst); if (srcAttr == 0xffffffff) { - if ((*tclWinProcs->getFullPathNameProc)(nativeSrc, 0, NULL, + if (GetFullPathName(nativeSrc, 0, NULL, NULL) >= MAX_PATH) { errno = ENAMETOOLONG; return TCL_ERROR; @@ -292,7 +292,7 @@ DoRenameFile( srcAttr = 0; } if (dstAttr == 0xffffffff) { - if ((*tclWinProcs->getFullPathNameProc)(nativeDst, 0, NULL, + if (GetFullPathName(nativeDst, 0, NULL, NULL) >= MAX_PATH) { errno = ENAMETOOLONG; return TCL_ERROR; @@ -308,28 +308,28 @@ DoRenameFile( decode: if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) { TCHAR *nativeSrcRest, *nativeDstRest; - CONST char **srcArgv, **dstArgv; + const char **srcArgv, **dstArgv; int size, srcArgc, dstArgc; - WCHAR nativeSrcPath[MAX_PATH]; - WCHAR nativeDstPath[MAX_PATH]; + TCHAR nativeSrcPath[MAX_PATH]; + TCHAR nativeDstPath[MAX_PATH]; Tcl_DString srcString, dstString; - CONST char *src, *dst; + const char *src, *dst; - size = (*tclWinProcs->getFullPathNameProc)(nativeSrc, MAX_PATH, + size = GetFullPathName(nativeSrc, MAX_PATH, nativeSrcPath, &nativeSrcRest); if ((size == 0) || (size > MAX_PATH)) { return TCL_ERROR; } - size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH, + size = GetFullPathName(nativeDst, MAX_PATH, nativeDstPath, &nativeDstRest); if ((size == 0) || (size > MAX_PATH)) { return TCL_ERROR; } - (*tclWinProcs->charLowerProc)((TCHAR *) nativeSrcPath); - (*tclWinProcs->charLowerProc)((TCHAR *) nativeDstPath); + CharLower(nativeSrcPath); + CharLower(nativeDstPath); - src = Tcl_WinTCharToUtf((TCHAR *) nativeSrcPath, -1, &srcString); - dst = Tcl_WinTCharToUtf((TCHAR *) nativeDstPath, -1, &dstString); + src = Tcl_WinTCharToUtf(nativeSrcPath, -1, &srcString); + dst = Tcl_WinTCharToUtf(nativeDstPath, -1, &dstString); /* * Check whether the destination path is actually inside the @@ -376,8 +376,8 @@ DoRenameFile( Tcl_SetErrno(EXDEV); } - ckfree((char *) srcArgv); - ckfree((char *) dstArgv); + ckfree(srcArgv); + ckfree(dstArgv); } /* @@ -408,7 +408,7 @@ DoRenameFile( * directory back, for completeness. */ - if ((*tclWinProcs->moveFileProc)(nativeSrc, + if (MoveFile(nativeSrc, nativeDst) != FALSE) { return TCL_OK; } @@ -419,8 +419,8 @@ DoRenameFile( */ TclWinConvertError(GetLastError()); - (*tclWinProcs->createDirectoryProc)(nativeDst, NULL); - (*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr); + CreateDirectory(nativeDst, NULL); + SetFileAttributes(nativeDst, dstAttr); if (Tcl_GetErrno() == EACCES) { /* * Decode the EACCES to a more meaningful error. @@ -447,22 +447,20 @@ DoRenameFile( TCHAR *nativeRest, *nativeTmp, *nativePrefix; int result, size; - WCHAR tempBuf[MAX_PATH]; + TCHAR tempBuf[MAX_PATH]; - size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH, + size = GetFullPathName(nativeDst, MAX_PATH, tempBuf, &nativeRest); if ((size == 0) || (size > MAX_PATH) || (nativeRest == NULL)) { return TCL_ERROR; } nativeTmp = (TCHAR *) tempBuf; - ((char *) nativeRest)[0] = '\0'; - ((char *) nativeRest)[1] = '\0'; /* In case it's Unicode. */ + nativeRest[0] = L'\0'; result = TCL_ERROR; - nativePrefix = (tclWinProcs->useWide) - ? (TCHAR *) L"tclr" : (TCHAR *) "tclr"; - if ((*tclWinProcs->getTempFileNameProc)(nativeTmp, - nativePrefix, 0, tempBuf) != 0) { + nativePrefix = (TCHAR *) L"tclr"; + if (GetTempFileName(nativeTmp, nativePrefix, + 0, tempBuf) != 0) { /* * Strictly speaking, need the following DeleteFile and * MoveFile to be joined as an atomic operation so no @@ -470,19 +468,16 @@ DoRenameFile( * same temp file. */ - nativeTmp = (TCHAR *) tempBuf; - (*tclWinProcs->deleteFileProc)(nativeTmp); - if ((*tclWinProcs->moveFileProc)(nativeDst, - nativeTmp) != FALSE) { - if ((*tclWinProcs->moveFileProc)(nativeSrc, - nativeDst) != FALSE) { - (*tclWinProcs->setFileAttributesProc)(nativeTmp, - FILE_ATTRIBUTE_NORMAL); - (*tclWinProcs->deleteFileProc)(nativeTmp); + nativeTmp = tempBuf; + DeleteFile(nativeTmp); + if (MoveFile(nativeDst, nativeTmp) != FALSE) { + if (MoveFile(nativeSrc, nativeDst) != FALSE) { + SetFileAttributes(nativeTmp, FILE_ATTRIBUTE_NORMAL); + DeleteFile(nativeTmp); return TCL_OK; } else { - (*tclWinProcs->deleteFileProc)(nativeDst); - (*tclWinProcs->moveFileProc)(nativeTmp, nativeDst); + DeleteFile(nativeDst); + MoveFile(nativeTmp, nativeDst); } } @@ -545,8 +540,8 @@ TclpObjCopyFile( static int DoCopyFile( - CONST TCHAR *nativeSrc, /* Pathname of file to be copied (native). */ - CONST TCHAR *nativeDst) /* Pathname of file to copy to (native). */ + const TCHAR *nativeSrc, /* Pathname of file to be copied (native). */ + const TCHAR *nativeDst) /* Pathname of file to copy to (native). */ { #if defined(HAVE_NO_SEH) && !defined(_WIN64) TCLEXCEPTION_REGISTRATION registration; @@ -649,7 +644,7 @@ DoCopyFile( [registration] "m" (registration), [nativeDst] "m" (nativeDst), [nativeSrc] "m" (nativeSrc), - [copyFile] "r" (tclWinProcs->copyFileProc) + [copyFile] "r" (CopyFile) : "%eax", "%ebx", "%ecx", "%edx", "memory" ); @@ -660,7 +655,7 @@ DoCopyFile( #ifndef HAVE_NO_SEH __try { #endif - if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) { + if (CopyFile(nativeSrc, nativeDst, 0) != FALSE) { retval = TCL_OK; } #ifndef HAVE_NO_SEH @@ -680,8 +675,8 @@ DoCopyFile( if (Tcl_GetErrno() == EACCES) { DWORD srcAttr, dstAttr; - srcAttr = (*tclWinProcs->getFileAttributesProc)(nativeSrc); - dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst); + srcAttr = GetFileAttributes(nativeSrc); + dstAttr = GetFileAttributes(nativeDst); if (srcAttr != 0xffffffff) { if (dstAttr == 0xffffffff) { dstAttr = 0; @@ -697,9 +692,9 @@ DoCopyFile( Tcl_SetErrno(EISDIR); } if (dstAttr & FILE_ATTRIBUTE_READONLY) { - (*tclWinProcs->setFileAttributesProc)(nativeDst, + SetFileAttributes(nativeDst, dstAttr & ~((DWORD)FILE_ATTRIBUTE_READONLY)); - if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, + if (CopyFile(nativeSrc, nativeDst, 0) != FALSE) { return TCL_OK; } @@ -710,7 +705,7 @@ DoCopyFile( */ TclWinConvertError(GetLastError()); - (*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr); + SetFileAttributes(nativeDst, dstAttr); } } } @@ -751,34 +746,35 @@ TclpObjDeleteFile( int TclpDeleteFile( - CONST TCHAR *nativePath) /* Pathname of file to be removed (native). */ + const void *nativePath) /* Pathname of file to be removed (native). */ { DWORD attr; + const TCHAR *path = nativePath; /* * The DeleteFile API acts differently under Win95/98 and NT WRT NULL and * "". Avoid passing these values. */ - if (nativePath == NULL || nativePath[0] == '\0') { + if (path == NULL || path[0] == '\0') { Tcl_SetErrno(ENOENT); return TCL_ERROR; } - if ((*tclWinProcs->deleteFileProc)(nativePath) != FALSE) { + if (DeleteFile(path) != FALSE) { return TCL_OK; } TclWinConvertError(GetLastError()); if (Tcl_GetErrno() == EACCES) { - attr = (*tclWinProcs->getFileAttributesProc)(nativePath); + attr = GetFileAttributes(path); if (attr != 0xffffffff) { if (attr & FILE_ATTRIBUTE_DIRECTORY) { if (attr & FILE_ATTRIBUTE_REPARSE_POINT) { /* * It is a symbolic link - remove it. */ - if (TclWinSymLinkDelete(nativePath, 0) == 0) { + if (TclWinSymLinkDelete(path, 0) == 0) { return TCL_OK; } } @@ -792,21 +788,21 @@ TclpDeleteFile( Tcl_SetErrno(EISDIR); } else if (attr & FILE_ATTRIBUTE_READONLY) { - int res = (*tclWinProcs->setFileAttributesProc)(nativePath, - attr & ~((DWORD)FILE_ATTRIBUTE_READONLY)); + int res = SetFileAttributes(path, + attr & ~((DWORD) FILE_ATTRIBUTE_READONLY)); - if ((res != 0) && ((*tclWinProcs->deleteFileProc)(nativePath) - != FALSE)) { + if ((res != 0) && + (DeleteFile(path) != FALSE)) { return TCL_OK; } TclWinConvertError(GetLastError()); if (res != 0) { - (*tclWinProcs->setFileAttributesProc)(nativePath, attr); + SetFileAttributes(path, attr); } } } } else if (Tcl_GetErrno() == ENOENT) { - attr = (*tclWinProcs->getFileAttributesProc)(nativePath); + attr = GetFileAttributes(path); if (attr != 0xffffffff) { if (attr & FILE_ATTRIBUTE_DIRECTORY) { /* @@ -863,11 +859,11 @@ TclpObjCreateDirectory( static int DoCreateDirectory( - CONST TCHAR *nativePath) /* Pathname of directory to create (native). */ + const TCHAR *nativePath) /* Pathname of directory to create (native). */ { - DWORD error; - if ((*tclWinProcs->createDirectoryProc)(nativePath, NULL) == 0) { - error = GetLastError(); + if (CreateDirectory(nativePath, NULL) == 0) { + DWORD error = GetLastError(); + TclWinConvertError(error); return TCL_ERROR; } @@ -996,13 +992,12 @@ TclpObjRemoveDirectory( } if (ret != TCL_OK) { - int len = Tcl_DStringLength(&ds); - if (len > 0) { + if (Tcl_DStringLength(&ds) > 0) { if (normPtr != NULL && !strcmp(Tcl_DStringValue(&ds), TclGetString(normPtr))) { *errorPtr = pathPtr; } else { - *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); + *errorPtr = TclDStringToObj(&ds); } Tcl_IncrRefCount(*errorPtr); } @@ -1014,7 +1009,7 @@ TclpObjRemoveDirectory( static int DoRemoveJustDirectory( - CONST TCHAR *nativePath, /* Pathname of directory to be removed + const TCHAR *nativePath, /* Pathname of directory to be removed * (native). */ int ignoreError, /* If non-zero, don't initialize the errorPtr * under some circumstances on return. */ @@ -1031,10 +1026,11 @@ DoRemoveJustDirectory( if (nativePath == NULL || nativePath[0] == '\0') { Tcl_SetErrno(ENOENT); - goto end; + Tcl_DStringInit(errorPtr); + return TCL_ERROR; } - attr = (*tclWinProcs->getFileAttributesProc)(nativePath); + attr = GetFileAttributes(nativePath); if (attr & FILE_ATTRIBUTE_REPARSE_POINT) { /* @@ -1048,7 +1044,7 @@ DoRemoveJustDirectory( * Ordinary directory. */ - if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) { + if (RemoveDirectory(nativePath) != FALSE) { return TCL_OK; } } @@ -1056,7 +1052,7 @@ DoRemoveJustDirectory( TclWinConvertError(GetLastError()); if (Tcl_GetErrno() == EACCES) { - attr = (*tclWinProcs->getFileAttributesProc)(nativePath); + attr = GetFileAttributes(nativePath); if (attr != 0xffffffff) { if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) { /* @@ -1080,60 +1076,17 @@ DoRemoveJustDirectory( if (attr & FILE_ATTRIBUTE_READONLY) { attr &= ~FILE_ATTRIBUTE_READONLY; - if ((*tclWinProcs->setFileAttributesProc)(nativePath, + if (SetFileAttributes(nativePath, attr) == FALSE) { goto end; } - if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) { + if (RemoveDirectory(nativePath) != FALSE) { return TCL_OK; } TclWinConvertError(GetLastError()); - (*tclWinProcs->setFileAttributesProc)(nativePath, + SetFileAttributes(nativePath, attr | FILE_ATTRIBUTE_READONLY); } - - /* - * Windows 95 and Win32s report removing a non-empty directory as - * EACCES, not EEXIST. If the directory is not empty, change errno - * so caller knows what's going on. - */ - - if (TclWinGetPlatformId() != VER_PLATFORM_WIN32_NT) { - CONST char *path, *find; - HANDLE handle; - WIN32_FIND_DATAA data; - Tcl_DString buffer; - int len; - - path = (CONST char *) nativePath; - - Tcl_DStringInit(&buffer); - len = strlen(path); - find = Tcl_DStringAppend(&buffer, path, len); - if ((len > 0) && (find[len - 1] != '\\')) { - Tcl_DStringAppend(&buffer, "\\", 1); - } - find = Tcl_DStringAppend(&buffer, "*.*", 3); - handle = FindFirstFileA(find, &data); - if (handle != INVALID_HANDLE_VALUE) { - while (1) { - if ((strcmp(data.cFileName, ".") != 0) - && (strcmp(data.cFileName, "..") != 0)) { - /* - * Found something in this directory. - */ - - Tcl_SetErrno(EEXIST); - break; - } - if (FindNextFileA(handle, &data) == FALSE) { - break; - } - } - FindClose(handle); - } - Tcl_DStringFree(&buffer); - } } } @@ -1156,9 +1109,7 @@ DoRemoveJustDirectory( end: if (errorPtr != NULL) { - char *p; - Tcl_WinTCharToUtf(nativePath, -1, errorPtr); - p = Tcl_DStringValue(errorPtr); + char *p = Tcl_WinTCharToUtf(nativePath, -1, errorPtr); for (; *p; ++p) { if (*p == '\\') *p = '/'; } @@ -1178,7 +1129,7 @@ DoRemoveDirectory( * filled with UTF-8 name of file causing * error. */ { - int res = DoRemoveJustDirectory(Tcl_DStringValue(pathPtr), recursive, + int res = DoRemoveJustDirectory((const TCHAR *)Tcl_DStringValue(pathPtr), recursive, errorPtr); if ((res == TCL_ERROR) && (recursive != 0) && (Tcl_GetErrno() == EEXIST)) { @@ -1232,7 +1183,7 @@ TraverseWinTree( TCHAR *nativeSource, *nativeTarget, *nativeErrfile; int result, found, sourceLen, targetLen = 0, oldSourceLen, oldTargetLen; HANDLE handle; - WIN32_FIND_DATAT data; + WIN32_FIND_DATA data; nativeErrfile = NULL; result = TCL_OK; @@ -1243,7 +1194,7 @@ TraverseWinTree( (targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr)); oldSourceLen = Tcl_DStringLength(sourcePtr); - sourceAttr = (*tclWinProcs->getFileAttributesProc)(nativeSource); + sourceAttr = GetFileAttributes(nativeSource); if (sourceAttr == 0xffffffff) { nativeErrfile = nativeSource; goto end; @@ -1254,7 +1205,7 @@ TraverseWinTree( * Process the symbolic link */ - return (*traverseProc)(nativeSource, nativeTarget, DOTREE_LINK, + return traverseProc(nativeSource, nativeTarget, DOTREE_LINK, errorPtr); } @@ -1263,18 +1214,14 @@ TraverseWinTree( * Process the regular file */ - return (*traverseProc)(nativeSource, nativeTarget, DOTREE_F, errorPtr); + return traverseProc(nativeSource, nativeTarget, DOTREE_F, errorPtr); } - if (tclWinProcs->useWide) { - Tcl_DStringAppend(sourcePtr, (char *) L"\\*.*", 4 * sizeof(WCHAR) + 1); - Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1); - } else { - Tcl_DStringAppend(sourcePtr, "\\*.*", 4); - } + Tcl_DStringAppend(sourcePtr, (char *) TEXT("\\*.*"), 4 * sizeof(TCHAR) + 1); + Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1); nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr); - handle = (*tclWinProcs->findFirstFileProc)(nativeSource, &data); + handle = FindFirstFile(nativeSource, &data); if (handle == INVALID_HANDLE_VALUE) { /* * Can't read directory. @@ -1285,67 +1232,44 @@ TraverseWinTree( goto end; } - nativeSource[oldSourceLen + 1] = '\0'; + Tcl_DStringSetLength(sourcePtr, oldSourceLen + 1); Tcl_DStringSetLength(sourcePtr, oldSourceLen); - result = (*traverseProc)(nativeSource, nativeTarget, DOTREE_PRED, + result = traverseProc(nativeSource, nativeTarget, DOTREE_PRED, errorPtr); if (result != TCL_OK) { FindClose(handle); return result; } - sourceLen = oldSourceLen; - - if (tclWinProcs->useWide) { - sourceLen += sizeof(WCHAR); - Tcl_DStringAppend(sourcePtr, (char *) L"\\", sizeof(WCHAR) + 1); - Tcl_DStringSetLength(sourcePtr, sourceLen); - } else { - sourceLen += 1; - Tcl_DStringAppend(sourcePtr, "\\", 1); - } + sourceLen = oldSourceLen + sizeof(TCHAR); + Tcl_DStringAppend(sourcePtr, (char *) TEXT("\\"), sizeof(TCHAR) + 1); + Tcl_DStringSetLength(sourcePtr, sourceLen); if (targetPtr != NULL) { oldTargetLen = Tcl_DStringLength(targetPtr); targetLen = oldTargetLen; - if (tclWinProcs->useWide) { - targetLen += sizeof(WCHAR); - Tcl_DStringAppend(targetPtr, (char *) L"\\", sizeof(WCHAR) + 1); - Tcl_DStringSetLength(targetPtr, targetLen); - } else { - targetLen += 1; - Tcl_DStringAppend(targetPtr, "\\", 1); - } + targetLen += sizeof(TCHAR); + Tcl_DStringAppend(targetPtr, (char *) TEXT("\\"), sizeof(TCHAR) + 1); + Tcl_DStringSetLength(targetPtr, targetLen); } found = 1; - for (; found; found = (*tclWinProcs->findNextFileProc)(handle, &data)) { + for (; found; found = FindNextFile(handle, &data)) { TCHAR *nativeName; int len; - if (tclWinProcs->useWide) { - WCHAR *wp; - - wp = data.w.cFileName; + TCHAR *wp = data.cFileName; + if (*wp == '.') { + wp++; if (*wp == '.') { wp++; - if (*wp == '.') { - wp++; - } - if (*wp == '\0') { - continue; - } } - nativeName = (TCHAR *) data.w.cFileName; - len = wcslen(data.w.cFileName) * sizeof(WCHAR); - } else { - if ((strcmp(data.a.cFileName, ".") == 0) - || (strcmp(data.a.cFileName, "..") == 0)) { + if (*wp == '\0') { continue; } - nativeName = (TCHAR *) data.a.cFileName; - len = strlen(data.a.cFileName); } + nativeName = (TCHAR *) data.cFileName; + len = _tcslen(data.cFileName) * sizeof(TCHAR); /* * Append name after slash, and recurse on the file. @@ -1390,8 +1314,8 @@ TraverseWinTree( * files in that directory. */ - result = (*traverseProc)(Tcl_DStringValue(sourcePtr), - (targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr)), + result = traverseProc((const TCHAR *)Tcl_DStringValue(sourcePtr), + (const TCHAR *)(targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr)), DOTREE_POSTD, errorPtr); } @@ -1426,8 +1350,8 @@ TraverseWinTree( static int TraversalCopy( - CONST TCHAR *nativeSrc, /* Source pathname to copy. */ - CONST TCHAR *nativeDst, /* Destination pathname of copy. */ + const TCHAR *nativeSrc, /* Source pathname to copy. */ + const TCHAR *nativeDst, /* Destination pathname of copy. */ int type, /* Reason for call - see TraverseWinTree() */ Tcl_DString *errorPtr) /* If non-NULL, initialized DString filled * with UTF-8 name of file causing error. */ @@ -1445,9 +1369,9 @@ TraversalCopy( break; case DOTREE_PRED: if (DoCreateDirectory(nativeDst) == TCL_OK) { - DWORD attr = (tclWinProcs->getFileAttributesProc)(nativeSrc); + DWORD attr = GetFileAttributes(nativeSrc); - if ((tclWinProcs->setFileAttributesProc)(nativeDst, + if (SetFileAttributes(nativeDst, attr) != FALSE) { return TCL_OK; } @@ -1492,8 +1416,8 @@ TraversalCopy( static int TraversalDelete( - CONST TCHAR *nativeSrc, /* Source pathname to delete. */ - CONST TCHAR *dstPtr, /* Not used. */ + const TCHAR *nativeSrc, /* Source pathname to delete. */ + const TCHAR *dstPtr, /* Not used. */ int type, /* Reason for call - see TraverseWinTree() */ Tcl_DString *errorPtr) /* If non-NULL, initialized DString filled * with UTF-8 name of file causing error. */ @@ -1548,8 +1472,8 @@ StatError( * error. */ { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "could not read \"", TclGetString(fileName), - "\": ", Tcl_PosixError(interp), (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("could not read \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); } /* @@ -1579,11 +1503,11 @@ GetWinFileAttributes( Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ { DWORD result; - CONST TCHAR *nativeName; + const TCHAR *nativeName; int attr; nativeName = Tcl_FSGetNativePath(fileName); - result = (*tclWinProcs->getFileAttributesProc)(nativeName); + result = GetFileAttributes(nativeName); if (result == 0xffffffff) { StatError(interp, fileName); @@ -1601,7 +1525,7 @@ GetWinFileAttributes( */ int len; - char *str = Tcl_GetStringFromObj(fileName,&len); + const char *str = Tcl_GetStringFromObj(fileName,&len); if (len < 4) { if (len == 0) { @@ -1667,9 +1591,11 @@ ConvertFileNameFormat( if (splitPath == NULL || pathc == 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not read \"", - Tcl_GetString(fileName), "\": no such file or directory", - (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read \"%s\": no such file or directory", + Tcl_GetString(fileName))); + errno = ENOENT; + Tcl_PosixError(interp); } goto cleanup; } @@ -1710,10 +1636,10 @@ ConvertFileNameFormat( Tcl_Obj *tempPath; Tcl_DString ds; Tcl_DString dsTemp; - TCHAR *nativeName; - char *tempString; + const TCHAR *nativeName; + const char *tempString; int tempLen; - WIN32_FIND_DATAT data; + WIN32_FIND_DATA data; HANDLE handle; DWORD attr; @@ -1729,7 +1655,7 @@ ConvertFileNameFormat( tempString = Tcl_GetStringFromObj(tempPath,&tempLen); nativeName = Tcl_WinUtfToTChar(tempString, tempLen, &ds); Tcl_DecrRefCount(tempPath); - handle = (*tclWinProcs->findFirstFileProc)(nativeName, &data); + handle = FindFirstFile(nativeName, &data); if (handle == INVALID_HANDLE_VALUE) { /* * FindFirstFile() doesn't like root directories. We would @@ -1738,7 +1664,7 @@ ConvertFileNameFormat( * root directory */ - attr = (*tclWinProcs->getFileAttributesProc)(nativeName); + attr = GetFileAttributes(nativeName); if ((attr!=0xFFFFFFFF) && (attr & FILE_ATTRIBUTE_DIRECTORY)) { Tcl_DStringFree(&ds); goto simple; @@ -1752,27 +1678,14 @@ ConvertFileNameFormat( } goto cleanup; } - if (tclWinProcs->useWide) { - nativeName = (TCHAR *) data.w.cAlternateFileName; - if (longShort) { - if (data.w.cFileName[0] != '\0') { - nativeName = (TCHAR *) data.w.cFileName; - } - } else { - if (data.w.cAlternateFileName[0] == '\0') { - nativeName = (TCHAR *) data.w.cFileName; - } + nativeName = data.cAlternateFileName; + if (longShort) { + if (data.cFileName[0] != '\0') { + nativeName = data.cFileName; } } else { - nativeName = (TCHAR *) data.a.cAlternateFileName; - if (longShort) { - if (data.a.cFileName[0] != '\0') { - nativeName = (TCHAR *) data.a.cFileName; - } - } else { - if (data.a.cAlternateFileName[0] == '\0') { - nativeName = (TCHAR *) data.a.cFileName; - } + if (data.cAlternateFileName[0] == '\0') { + nativeName = (TCHAR *) data.cFileName; } } @@ -1790,22 +1703,21 @@ ConvertFileNameFormat( Tcl_DStringInit(&dsTemp); Tcl_WinTCharToUtf(nativeName, -1, &dsTemp); + Tcl_DStringFree(&ds); /* * Deal with issues of tildes being absolute. */ if (Tcl_DStringValue(&dsTemp)[0] == '~') { - tempPath = Tcl_NewStringObj("./",2); + TclNewLiteralStringObj(tempPath, "./"); Tcl_AppendToObj(tempPath, Tcl_DStringValue(&dsTemp), Tcl_DStringLength(&dsTemp)); + Tcl_DStringFree(&dsTemp); } else { - tempPath = Tcl_NewStringObj(Tcl_DStringValue(&dsTemp), - Tcl_DStringLength(&dsTemp)); + tempPath = TclDStringToObj(&dsTemp); } Tcl_ListObjReplace(NULL, splitPath, i, 1, 1, &tempPath); - Tcl_DStringFree(&ds); - Tcl_DStringFree(&dsTemp); FindClose(handle); } } @@ -1917,13 +1829,12 @@ SetWinFileAttributes( Tcl_Obj *fileName, /* The name of the file. */ Tcl_Obj *attributePtr) /* The new value of the attribute. */ { - DWORD fileAttributes; - int yesNo; - int result; - CONST TCHAR *nativeName; + DWORD fileAttributes, old; + int yesNo, result; + const TCHAR *nativeName; nativeName = Tcl_FSGetNativePath(fileName); - fileAttributes = (*tclWinProcs->getFileAttributesProc)(nativeName); + fileAttributes = old = GetFileAttributes(nativeName); if (fileAttributes == 0xffffffff) { StatError(interp, fileName); @@ -1941,7 +1852,8 @@ SetWinFileAttributes( fileAttributes &= ~(attributeArray[objIndex]); } - if (!(*tclWinProcs->setFileAttributesProc)(nativeName, fileAttributes)) { + if ((fileAttributes != old) + && !SetFileAttributes(nativeName, fileAttributes)) { StatError(interp, fileName); return TCL_ERROR; } @@ -1972,13 +1884,13 @@ CannotSetAttribute( Tcl_Obj *fileName, /* The name of the file. */ Tcl_Obj *attributePtr) /* The new value of the attribute. */ { - Tcl_AppendResult(interp, "cannot set attribute \"", - tclpFileAttrStrings[objIndex], "\" for file \"", - Tcl_GetString(fileName), "\": attribute is readonly", - (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot set attribute \"%s\" for file \"%s\": attribute is readonly", + tclpFileAttrStrings[objIndex], Tcl_GetString(fileName))); + errno = EINVAL; + Tcl_PosixError(interp); return TCL_ERROR; } - /* *--------------------------------------------------------------------------- @@ -1996,7 +1908,7 @@ CannotSetAttribute( *--------------------------------------------------------------------------- */ -Tcl_Obj* +Tcl_Obj * TclpObjListVolumes(void) { Tcl_Obj *resultPtr, *elemPtr; diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 8ee4bce..b9787c7 100755 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -16,9 +16,13 @@ #include "tclFileSystem.h" #include <winioctl.h> #include <shlobj.h> -#include <lmaccess.h> /* For TclpGetUserHome(). */ +#include <lm.h> /* For TclpGetUserHome(). */ #include <userenv.h> /* For TclpGetUserHome(). */ +#include <aclapi.h> /* For GetNamedSecurityInfo */ +#ifdef _MSC_VER +# pragma comment(lib, "userenv.lib") +#endif /* * The number of 100-ns intervals between the Windows system epoch (1601-01-01 * on the proleptic Gregorian calendar) and the Posix epoch (1970-01-01). @@ -141,28 +145,6 @@ typedef struct { WCHAR dummyBuf[MAX_PATH * 3]; } DUMMY_REPARSE_BUFFER; -#if defined(_MSC_VER) && (_MSC_VER <= 1100) -#undef HAVE_NO_FINDEX_ENUMS -#define HAVE_NO_FINDEX_ENUMS -#elif !defined(_WIN32_WINNT) || (_WIN32_WINNT < 0x0400) -#undef HAVE_NO_FINDEX_ENUMS -#define HAVE_NO_FINDEX_ENUMS -#endif - -#ifdef HAVE_NO_FINDEX_ENUMS -/* These two aren't in VC++ 5.2 headers */ -typedef enum _FINDEX_INFO_LEVELS { - FindExInfoStandard, - FindExInfoMaxInfoLevel -} FINDEX_INFO_LEVELS; -typedef enum _FINDEX_SEARCH_OPS { - FindExSearchNameMatch, - FindExSearchLimitToDirectories, - FindExSearchLimitToDevices, - FindExSearchMaxSearchOp -} FINDEX_SEARCH_OPS; -#endif /* HAVE_NO_FINDEX_ENUMS */ - /* * Other typedefs required by this code. */ @@ -170,18 +152,6 @@ typedef enum _FINDEX_SEARCH_OPS { static time_t ToCTime(FILETIME fileTime); static void FromCTime(time_t posixTime, FILETIME *fileTime); -typedef NET_API_STATUS NET_API_FUNCTION NETUSERGETINFOPROC( - LPWSTR servername, LPWSTR username, DWORD level, LPBYTE *bufptr); - -typedef NET_API_STATUS NET_API_FUNCTION NETAPIBUFFERFREEPROC(LPVOID Buffer); - -typedef NET_API_STATUS NET_API_FUNCTION NETGETDCNAMEPROC( - LPWSTR servername, LPWSTR domainname, LPBYTE *bufptr); - -typedef BOOL WINAPI GETPROFILESDIRECTORYPROC( - LPWSTR lpProfilesDir, LPDWORD lpcchSize -); - /* * Declarations for local functions defined in this file: */ @@ -207,6 +177,7 @@ static int WinLink(const TCHAR *LinkSource, const TCHAR *LinkTarget, int linkAction); static int WinSymLinkDirectory(const TCHAR *LinkDirectory, const TCHAR *LinkTarget); +MODULE_SCOPE TCL_NORETURN void tclWinDebugPanic(const char *format, ...); /* *-------------------------------------------------------------------- @@ -224,7 +195,7 @@ WinLink( const TCHAR *linkTargetPath, int linkAction) { - WCHAR tempFileName[MAX_PATH]; + TCHAR tempFileName[MAX_PATH]; TCHAR *tempFilePart; DWORD attr; @@ -232,8 +203,8 @@ WinLink( * Get the full path referenced by the target. */ - if (!(*tclWinProcs->getFullPathNameProc)(linkTargetPath, MAX_PATH, - tempFileName, &tempFilePart)) { + if (!GetFullPathName(linkTargetPath, MAX_PATH, tempFileName, + &tempFilePart)) { /* * Invalid file. */ @@ -246,7 +217,7 @@ WinLink( * Make sure source file doesn't exist. */ - attr = (*tclWinProcs->getFileAttributesProc)(linkSourcePath); + attr = GetFileAttributes(linkSourcePath); if (attr != INVALID_FILE_ATTRIBUTES) { Tcl_SetErrno(EEXIST); return -1; @@ -256,8 +227,8 @@ WinLink( * Get the full path referenced by the source file/directory. */ - if (!(*tclWinProcs->getFullPathNameProc)(linkSourcePath, MAX_PATH, - tempFileName, &tempFilePart)) { + if (!GetFullPathName(linkSourcePath, MAX_PATH, tempFileName, + &tempFilePart)) { /* * Invalid file. */ @@ -270,43 +241,36 @@ WinLink( * Check the target. */ - attr = (*tclWinProcs->getFileAttributesProc)(linkTargetPath); + attr = GetFileAttributes(linkTargetPath); if (attr == INVALID_FILE_ATTRIBUTES) { /* * The target doesn't exist. */ TclWinConvertError(GetLastError()); - return -1; - } else if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) { /* * It is a file. */ - if (tclWinProcs->createHardLinkProc == NULL) { - Tcl_SetErrno(ENOTDIR); - return -1; - } - if (linkAction & TCL_CREATE_HARD_LINK) { - if (!(*tclWinProcs->createHardLinkProc)(linkSourcePath, - linkTargetPath, NULL)) { - TclWinConvertError(GetLastError()); - return -1; + if (CreateHardLink(linkSourcePath, linkTargetPath, NULL)) { + /* + * Success! + */ + + return 0; } - return 0; + TclWinConvertError(GetLastError()); } else if (linkAction & TCL_CREATE_SYMBOLIC_LINK) { /* * Can't symlink files. */ Tcl_SetErrno(ENOTDIR); - return -1; } else { Tcl_SetErrno(ENODEV); - return -1; } } else { /* @@ -323,12 +287,11 @@ WinLink( */ Tcl_SetErrno(EISDIR); - return -1; } else { Tcl_SetErrno(ENODEV); - return -1; } } + return -1; } /* @@ -345,7 +308,7 @@ static Tcl_Obj * WinReadLink( const TCHAR *linkSourcePath) { - WCHAR tempFileName[MAX_PATH]; + TCHAR tempFileName[MAX_PATH]; TCHAR *tempFilePart; DWORD attr; @@ -353,8 +316,8 @@ WinReadLink( * Get the full path referenced by the target. */ - if (!(*tclWinProcs->getFullPathNameProc)(linkSourcePath, MAX_PATH, - tempFileName, &tempFilePart)) { + if (!GetFullPathName(linkSourcePath, MAX_PATH, tempFileName, + &tempFilePart)) { /* * Invalid file. */ @@ -367,7 +330,7 @@ WinReadLink( * Make sure source file does exist. */ - attr = (*tclWinProcs->getFileAttributesProc)(linkSourcePath); + attr = GetFileAttributes(linkSourcePath); if (attr == INVALID_FILE_ATTRIBUTES) { /* * The source doesn't exist. @@ -383,9 +346,9 @@ WinReadLink( Tcl_SetErrno(ENOTDIR); return NULL; - } else { - return WinReadLinkDirectory(linkSourcePath); } + + return WinReadLinkDirectory(linkSourcePath); } /* @@ -524,9 +487,8 @@ TclWinSymLinkDelete( memset(reparseBuffer, 0, sizeof(DUMMY_REPARSE_BUFFER)); reparseBuffer->ReparseTag = IO_REPARSE_TAG_MOUNT_POINT; - hFile = (*tclWinProcs->createFileProc)(linkOrigPath, GENERIC_WRITE, 0, - NULL, OPEN_EXISTING, - FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL); + hFile = CreateFile(linkOrigPath, GENERIC_WRITE, 0, NULL, OPEN_EXISTING, + FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL); if (hFile != INVALID_HANDLE_VALUE) { if (!DeviceIoControl(hFile, FSCTL_DELETE_REPARSE_POINT, reparseBuffer, @@ -540,7 +502,7 @@ TclWinSymLinkDelete( } else { CloseHandle(hFile); if (!linkOnly) { - (*tclWinProcs->removeDirectoryProc)(linkOrigPath); + RemoveDirectory(linkOrigPath); } return 0; } @@ -585,7 +547,7 @@ WinReadLinkDirectory( Tcl_DString ds; const char *copy; - attr = (*tclWinProcs->getFileAttributesProc)(linkDirPath); + attr = GetFileAttributes(linkDirPath); if (!(attr & FILE_ATTRIBUTE_REPARSE_POINT)) { goto invalidError; } @@ -610,6 +572,7 @@ WinReadLinkDirectory( */ offset = 0; +#ifdef UNICODE if (reparseBuffer->MountPointReparseBuffer.PathBuffer[0] == L'\\') { /* * Check whether this is a mounted volume. @@ -671,8 +634,9 @@ WinReadLinkDirectory( offset = 4; } } +#endif /* UNICODE */ - Tcl_WinTCharToUtf((const char *) + Tcl_WinTCharToUtf((const TCHAR *) reparseBuffer->MountPointReparseBuffer.PathBuffer, (int) reparseBuffer->MountPointReparseBuffer .SubstituteNameLength, &ds); @@ -718,9 +682,8 @@ NativeReadReparse( HANDLE hFile; DWORD returnedLength; - hFile = (*tclWinProcs->createFileProc)(linkDirPath, desiredAccess, FILE_SHARE_READ, - NULL, OPEN_EXISTING, - FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL); + hFile = CreateFile(linkDirPath, desiredAccess, FILE_SHARE_READ, NULL, OPEN_EXISTING, + FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL); if (hFile == INVALID_HANDLE_VALUE) { /* @@ -778,7 +741,7 @@ NativeWriteReparse( * Create the directory - it must not already exist. */ - if ((*tclWinProcs->createDirectoryProc)(linkDirPath, NULL) == 0) { + if (CreateDirectory(linkDirPath, NULL) == 0) { /* * Error creating directory. */ @@ -786,9 +749,9 @@ NativeWriteReparse( TclWinConvertError(GetLastError()); return -1; } - hFile = (*tclWinProcs->createFileProc)(linkDirPath, GENERIC_WRITE, 0, - NULL, OPEN_EXISTING, - FILE_FLAG_OPEN_REPARSE_POINT|FILE_FLAG_BACKUP_SEMANTICS, NULL); + hFile = CreateFile(linkDirPath, GENERIC_WRITE, 0, NULL, + OPEN_EXISTING, FILE_FLAG_OPEN_REPARSE_POINT + | FILE_FLAG_BACKUP_SEMANTICS, NULL); if (hFile == INVALID_HANDLE_VALUE) { /* * Error creating directory. @@ -811,7 +774,7 @@ NativeWriteReparse( TclWinConvertError(GetLastError()); CloseHandle(hFile); - (*tclWinProcs->removeDirectoryProc)(linkDirPath); + RemoveDirectory(linkDirPath); return -1; } CloseHandle(hFile); @@ -824,6 +787,65 @@ NativeWriteReparse( } /* + *---------------------------------------------------------------------- + * + * tclWinDebugPanic -- + * + * Display a message. If a debugger is present, present it directly to + * the debugger, otherwise use a MessageBox. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +TCL_NORETURN void +tclWinDebugPanic( + const char *format, ...) +{ +#define TCL_MAX_WARN_LEN 1024 + va_list argList; + char buf[TCL_MAX_WARN_LEN * TCL_UTF_MAX]; + WCHAR msgString[TCL_MAX_WARN_LEN]; + + va_start(argList, format); + vsnprintf(buf, sizeof(buf), format, argList); + + msgString[TCL_MAX_WARN_LEN-1] = L'\0'; + MultiByteToWideChar(CP_UTF8, 0, buf, -1, msgString, TCL_MAX_WARN_LEN); + + /* + * Truncate MessageBox string if it is too long to not overflow the screen + * and cause possible oversized window error. + */ + + if (msgString[TCL_MAX_WARN_LEN-1] != L'\0') { + memcpy(msgString + (TCL_MAX_WARN_LEN - 5), L" ...", 5 * sizeof(WCHAR)); + } + if (IsDebuggerPresent()) { + OutputDebugStringW(msgString); + } else { + MessageBeep(MB_ICONEXCLAMATION); + MessageBoxW(NULL, msgString, L"Fatal Error", + MB_ICONSTOP | MB_OK | MB_TASKMODAL | MB_SETFOREGROUND); + } +#if defined(__GNUC__) + __builtin_trap(); +#elif defined(_WIN64) + __debugbreak(); +#elif defined(_MSC_VER) && defined (_M_IX86) + _asm {int 3} +#else + DebugBreak(); +#endif + abort(); +} + +/* *--------------------------------------------------------------------------- * * TclpFindExecutable -- @@ -842,28 +864,33 @@ NativeWriteReparse( void TclpFindExecutable( - const char *argv0) /* The value of the application's argv[0] - * (native). */ + const char *argv0) /* If NULL, install PanicMessageBox, otherwise + * ignore. */ { WCHAR wName[MAX_PATH]; char name[MAX_PATH * TCL_UTF_MAX]; /* * Under Windows we ignore argv0, and return the path for the file used to - * create this process. + * create this process. Only if it is NULL, install a new panic handler. */ - if (GetModuleFileNameW(NULL, wName, MAX_PATH) == 0) { - GetModuleFileNameA(NULL, name, sizeof(name)); + if (argv0 == NULL) { + Tcl_SetPanicProc(tclWinDebugPanic); + } - /* - * Convert to WCHAR to get out of ANSI codepage - */ +#ifdef UNICODE + GetModuleFileNameW(NULL, wName, MAX_PATH); +#else + GetModuleFileNameA(NULL, name, sizeof(name)); - MultiByteToWideChar(CP_ACP, 0, name, -1, wName, MAX_PATH); - } + /* + * Convert to WCHAR to get out of ANSI codepage + */ - WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, sizeof(name), NULL,NULL); + MultiByteToWideChar(CP_ACP, 0, name, -1, wName, MAX_PATH); +#endif + WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, sizeof(name), NULL, NULL); TclWinNoBackslash(name); TclSetObjNameOfExecutable(Tcl_NewStringObj(name, -1), NULL); } @@ -909,6 +936,7 @@ TclpMatchInDirectory( if (pattern == NULL || (*pattern == '\0')) { Tcl_Obj *norm = Tcl_FSGetNormalizedPath(NULL, pathPtr); + if (norm != NULL) { /* * Match a single file directly. @@ -916,23 +944,16 @@ TclpMatchInDirectory( int len; DWORD attr; + WIN32_FILE_ATTRIBUTE_DATA data; const char *str = Tcl_GetStringFromObj(norm,&len); - native = (const TCHAR *) Tcl_FSGetNativePath(pathPtr); + native = Tcl_FSGetNativePath(pathPtr); - if (tclWinProcs->getFileAttributesExProc == NULL) { - attr = (*tclWinProcs->getFileAttributesProc)(native); - if (attr == 0xffffffff) { - return TCL_OK; - } - } else { - WIN32_FILE_ATTRIBUTE_DATA data; - if ((*tclWinProcs->getFileAttributesExProc)(native, - GetFileExInfoStandard, &data) != TRUE) { - return TCL_OK; - } - attr = data.dwFileAttributes; + if (GetFileAttributesEx(native, + GetFileExInfoStandard, &data) != TRUE) { + return TCL_OK; } + attr = data.dwFileAttributes; if (NativeMatchType(WinIsDrive(str,len), attr, native, types)) { Tcl_ListObjAppendElement(interp, resultPtr, pathPtr); @@ -942,7 +963,7 @@ TclpMatchInDirectory( } else { DWORD attr; HANDLE handle; - WIN32_FIND_DATAT data; + WIN32_FIND_DATA data; const char *dirName; /* UTF-8 dir name, later with pattern * appended. */ int dirLength; @@ -971,9 +992,10 @@ TclpMatchInDirectory( if (native == NULL) { return TCL_OK; } - attr = (*tclWinProcs->getFileAttributesProc)(native); + attr = GetFileAttributes(native); - if ((attr == 0xffffffff) || ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0)) { + if ((attr == INVALID_FILE_ATTRIBUTES) + || ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0)) { return TCL_OK; } @@ -988,7 +1010,7 @@ TclpMatchInDirectory( lastChar = dirName[dirLength -1]; if ((lastChar != '\\') && (lastChar != '/') && (lastChar != ':')) { - Tcl_DStringAppend(&dsOrig, "/", 1); + TclDStringAppendLiteral(&dsOrig, "/"); dirLength++; } dirName = Tcl_DStringValue(&dsOrig); @@ -1008,25 +1030,25 @@ TclpMatchInDirectory( dirName = Tcl_DStringAppend(&dsOrig, pattern, -1); } else { - dirName = Tcl_DStringAppend(&dsOrig, "*.*", 3); + dirName = TclDStringAppendLiteral(&dsOrig, "*.*"); } native = Tcl_WinUtfToTChar(dirName, -1, &ds); - if (tclWinProcs->findFirstFileExProc == NULL || (types == NULL) - || (types->type != TCL_GLOB_TYPE_DIR)) { - handle = (*tclWinProcs->findFirstFileProc)(native, &data); + if ((types == NULL) || (types->type != TCL_GLOB_TYPE_DIR)) { + handle = FindFirstFile(native, &data); } else { /* * We can be more efficient, for pure directory requests. */ - handle = (*tclWinProcs->findFirstFileExProc)(native, + handle = FindFirstFileEx(native, FindExInfoStandard, &data, FindExSearchLimitToDirectories, NULL, 0); } if (handle == INVALID_HANDLE_VALUE) { DWORD err = GetLastError(); + Tcl_DStringFree(&ds); if (err == ERROR_FILE_NOT_FOUND) { /* @@ -1040,10 +1062,9 @@ TclpMatchInDirectory( TclWinConvertError(err); if (interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't read directory \"", - Tcl_DStringValue(&dsOrig), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read directory \"%s\": %s", + Tcl_DStringValue(&dsOrig), Tcl_PosixError(interp))); } Tcl_DStringFree(&dsOrig); return TCL_ERROR; @@ -1083,14 +1104,8 @@ TclpMatchInDirectory( int checkDrive = 0, isDrive; DWORD attr; - if (tclWinProcs->useWide) { - native = (const TCHAR *) data.w.cFileName; - attr = data.w.dwFileAttributes; - } else { - native = (const TCHAR *) data.a.cFileName; - attr = data.a.dwFileAttributes; - } - + native = data.cFileName; + attr = data.dwFileAttributes; utfname = Tcl_WinTCharToUtf(native, -1, &ds); if (!matchSpecialDots) { @@ -1133,6 +1148,7 @@ TclpMatchInDirectory( if (checkDrive) { const char *fullname = Tcl_DStringAppend(&dsOrig, utfname, Tcl_DStringLength(&ds)); + isDrive = WinIsDrive(fullname, Tcl_DStringLength(&dsOrig)); Tcl_DStringSetLength(&dsOrig, dirLength); } else { @@ -1150,7 +1166,7 @@ TclpMatchInDirectory( */ Tcl_DStringFree(&ds); - } while ((*tclWinProcs->findNextFileProc)(handle, &data) == TRUE); + } while (FindNextFile(handle, &data) == TRUE); FindClose(handle); Tcl_DStringFree(&dsOrig); @@ -1323,92 +1339,85 @@ NativeMatchType( * If invisible, don't return the file. */ - if (attr & FILE_ATTRIBUTE_HIDDEN && !isDrive) { + return !(attr & FILE_ATTRIBUTE_HIDDEN && !isDrive); + } + + if (attr & FILE_ATTRIBUTE_HIDDEN && !isDrive) { + /* + * If invisible. + */ + + if ((types->perm == 0) || !(types->perm & TCL_GLOB_PERM_HIDDEN)) { return 0; } } else { - if (attr & FILE_ATTRIBUTE_HIDDEN && !isDrive) { - /* - * If invisible. - */ - - if ((types->perm == 0) || !(types->perm & TCL_GLOB_PERM_HIDDEN)) { - return 0; - } - } else { - /* - * Visible. - */ + /* + * Visible. + */ - if (types->perm & TCL_GLOB_PERM_HIDDEN) { - return 0; - } + if (types->perm & TCL_GLOB_PERM_HIDDEN) { + return 0; } + } - if (types->perm != 0) { - if (((types->perm & TCL_GLOB_PERM_RONLY) && - !(attr & FILE_ATTRIBUTE_READONLY)) || - ((types->perm & TCL_GLOB_PERM_R) && - (0 /* File exists => R_OK on Windows */)) || - ((types->perm & TCL_GLOB_PERM_W) && - (attr & FILE_ATTRIBUTE_READONLY)) || - ((types->perm & TCL_GLOB_PERM_X) && - (!(attr & FILE_ATTRIBUTE_DIRECTORY) - && !NativeIsExec(nativeName)))) { - return 0; - } + if (types->perm != 0) { + if (((types->perm & TCL_GLOB_PERM_RONLY) && + !(attr & FILE_ATTRIBUTE_READONLY)) || + ((types->perm & TCL_GLOB_PERM_R) && + (0 /* File exists => R_OK on Windows */)) || + ((types->perm & TCL_GLOB_PERM_W) && + (attr & FILE_ATTRIBUTE_READONLY)) || + ((types->perm & TCL_GLOB_PERM_X) && + (!(attr & FILE_ATTRIBUTE_DIRECTORY) + && !NativeIsExec(nativeName)))) { + return 0; } - if ((types->type & TCL_GLOB_TYPE_DIR) - && (attr & FILE_ATTRIBUTE_DIRECTORY)) { - /* - * Quicker test for directory, which is a common case. - */ + } - return 1; + if ((types->type & TCL_GLOB_TYPE_DIR) + && (attr & FILE_ATTRIBUTE_DIRECTORY)) { + /* + * Quicker test for directory, which is a common case. + */ - } else if (types->type != 0) { - unsigned short st_mode; - int isExec = NativeIsExec(nativeName); + return 1; - st_mode = NativeStatMode(attr, 0, isExec); + } else if (types->type != 0) { + unsigned short st_mode; + int isExec = NativeIsExec(nativeName); - /* - * In order bcdpfls as in 'find -t' - */ + st_mode = NativeStatMode(attr, 0, isExec); + + /* + * 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; } -static void -FreeLoadLibHandle( - ClientData clientData) -{ - FreeLibrary((HMODULE)clientData); -} /* *---------------------------------------------------------------------- * @@ -1430,134 +1439,90 @@ FreeLoadLibHandle( *---------------------------------------------------------------------- */ -char * +const char * TclpGetUserHome( const char *name, /* User name for desired home directory. */ Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with * name of user's home directory. */ { - char *result; - - static NETAPIBUFFERFREEPROC *netApiBufferFreeProc; - static NETGETDCNAMEPROC *netGetDCNameProc; - static NETUSERGETINFOPROC *netUserGetInfoProc; - static GETPROFILESDIRECTORYPROC *getProfilesDirectoryProc; - static int apistubs = 0; + char *result = NULL; + USER_INFO_1 *uiPtr; + Tcl_DString ds; + int nameLen = -1; + int rc = 0; + const char *domain; + WCHAR *wName, *wHomeDir, *wDomain; + WCHAR buf[MAX_PATH]; - result = NULL; Tcl_DStringInit(bufferPtr); - if (!apistubs) { - HINSTANCE handle; - TCL_DECLARE_MUTEX(initializeMutex) - Tcl_MutexLock(&initializeMutex); - if (!apistubs) { - handle = LoadLibraryA("netapi32.dll"); - if (handle) { - netApiBufferFreeProc = (NETAPIBUFFERFREEPROC *) - GetProcAddress(handle, "NetApiBufferFree"); - netGetDCNameProc = (NETGETDCNAMEPROC *) - GetProcAddress(handle, "NetGetDCName"); - netUserGetInfoProc = (NETUSERGETINFOPROC *) - GetProcAddress(handle, "NetUserGetInfo"); - Tcl_CreateExitHandler(FreeLoadLibHandle, handle); - } - handle = LoadLibraryA("userenv.dll"); - if (handle) { - getProfilesDirectoryProc = (GETPROFILESDIRECTORYPROC *) - GetProcAddress(handle, "GetProfilesDirectoryW"); - Tcl_CreateExitHandler(FreeLoadLibHandle, handle); - } - - apistubs = -1; - if ( (netUserGetInfoProc != NULL) && (netGetDCNameProc != NULL) - && (netApiBufferFreeProc != NULL) && (getProfilesDirectoryProc != NULL) - ) { - apistubs = 1; + wDomain = NULL; + domain = Tcl_UtfFindFirst(name, '@'); + if (domain == NULL) { + const char *ptr; + + /* no domain - firstly check it's the current user */ + if ( (ptr = TclpGetUserName(&ds)) != NULL + && strcasecmp(name, ptr) == 0 + ) { + /* try safest and fastest way to get current user home */ + ptr = TclGetEnv("HOME", &ds); + if (ptr != NULL) { + Tcl_JoinPath(1, &ptr, bufferPtr); + rc = 1; + result = Tcl_DStringValue(bufferPtr); } } - Tcl_MutexUnlock(&initializeMutex); - } - - if (apistubs == 1) { - USER_INFO_1 *uiPtr; - Tcl_DString ds; - int nameLen, rc; - const char *domain; - WCHAR *wName, *wHomeDir, *wDomain; - WCHAR buf[MAX_PATH]; - - rc = 0; - nameLen = -1; - wDomain = NULL; - domain = Tcl_UtfFindFirst(name, '@'); - if (domain == NULL) { - const char *ptr; - - /* no domain - firstly check it's the current user */ - if ( (ptr = TclpGetUserName(&ds)) != NULL - && strcasecmp(name, ptr) == 0 - ) { - /* try safest and fastest way to get current user home */ - ptr = TclGetEnv("HOME", &ds); - if (ptr != NULL) { - Tcl_JoinPath(1, &ptr, bufferPtr); - rc = 1; - result = Tcl_DStringValue(bufferPtr); - } - } - Tcl_DStringFree(&ds); - } else { - Tcl_DStringInit(&ds); - wName = Tcl_UtfToUniCharDString(domain + 1, -1, &ds); - rc = (netGetDCNameProc)(NULL, wName, (LPBYTE *) &wDomain); - Tcl_DStringFree(&ds); - nameLen = domain - name; + Tcl_DStringFree(&ds); + } else { + Tcl_DStringInit(&ds); + wName = Tcl_UtfToUniCharDString(domain + 1, -1, &ds); + rc = NetGetDCName(NULL, wName, (LPBYTE *) &wDomain); + Tcl_DStringFree(&ds); + nameLen = domain - name; + } + if (rc == 0) { + Tcl_DStringInit(&ds); + wName = Tcl_UtfToUniCharDString(name, nameLen, &ds); + while (NetUserGetInfo(wDomain, wName, 1, (LPBYTE *) &uiPtr) != 0) { + /* + * user does not exists - if domain was not specified, + * try again using current domain. + */ + rc = 1; + if (domain != NULL) break; + /* get current domain */ + rc = NetGetDCName(NULL, NULL, (LPBYTE *) &wDomain); + if (rc != 0) break; + domain = INT2PTR(-1); /* repeat once */ } if (rc == 0) { - Tcl_DStringInit(&ds); - wName = Tcl_UtfToUniCharDString(name, nameLen, &ds); - while ((netUserGetInfoProc)(wDomain, wName, 1, - (LPBYTE *) &uiPtr) != 0) { - /* - * user does not exists - if domain was not specified, - * try again using current domain. + DWORD i, size = MAX_PATH; + wHomeDir = uiPtr->usri1_home_dir; + if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) { + size = lstrlenW(wHomeDir); + Tcl_UniCharToUtfDString(wHomeDir, size, bufferPtr); + } else { + /* + * User exists but has no home dir. Return + * "{GetProfilesDirectory}/<user>". */ - rc = 1; - if (domain != NULL) break; - /* get current domain */ - rc = (netGetDCNameProc)(NULL, NULL, (LPBYTE *) &wDomain); - if (rc != 0) break; - domain = INT2PTR(-1); /* repeat once */ + GetProfilesDirectoryW(buf, &size); + Tcl_UniCharToUtfDString(buf, size-1, bufferPtr); + Tcl_DStringAppend(bufferPtr, "/", 1); + Tcl_DStringAppend(bufferPtr, name, nameLen); } - if (rc == 0) { - DWORD i, size = MAX_PATH; - wHomeDir = uiPtr->usri1_home_dir; - if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) { - size = lstrlenW(wHomeDir); - Tcl_UniCharToUtfDString(wHomeDir, size, bufferPtr); - } else { - /* - * User exists but has no home dir. Return - * "{GetProfilesDirectory}/<user>". - */ - getProfilesDirectoryProc(buf, &size); - Tcl_UniCharToUtfDString(buf, size-1, bufferPtr); - Tcl_DStringAppend(bufferPtr, "/", 1); - Tcl_DStringAppend(bufferPtr, name, nameLen); - } - result = Tcl_DStringValue(bufferPtr); - /* be sure we returns normalized path */ - for (i = 0; i < size; ++i){ - if (result[i] == '\\') result[i] = '/'; - } - (*netApiBufferFreeProc)((void *) uiPtr); + result = Tcl_DStringValue(bufferPtr); + /* be sure we returns normalized path */ + for (i = 0; i < size; ++i){ + if (result[i] == '\\') result[i] = '/'; } - Tcl_DStringFree(&ds); - } - if (wDomain != NULL) { - (*netApiBufferFreeProc)((void *) wDomain); + NetApiBufferFree((void *) uiPtr); } + Tcl_DStringFree(&ds); + } + if (wDomain != NULL) { + NetApiBufferFree((void *) wDomain); } if (result == NULL) { /* @@ -1613,9 +1578,9 @@ NativeAccess( { DWORD attr; - attr = (*tclWinProcs->getFileAttributesProc)(nativePath); + attr = GetFileAttributes(nativePath); - if (attr == 0xffffffff) { + if (attr == INVALID_FILE_ATTRIBUTES) { /* * File might not exist. */ @@ -1666,7 +1631,7 @@ NativeAccess( if (mode & W_OK) { mask |= GENERIC_WRITE; } if (mode & X_OK) { mask |= GENERIC_EXECUTE; } - hFile = (tclWinProcs->createFileProc)(nativePath, mask, + hFile = CreateFile(nativePath, mask, FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE, NULL, OPEN_EXISTING, FILE_FLAG_NO_BUFFERING, NULL); if (hFile != INVALID_HANDLE_VALUE) { @@ -1689,7 +1654,8 @@ NativeAccess( * what permissions the OS has set for a file. */ - if (tclWinProcs->getFileSecurityProc != NULL) { +#ifdef UNICODE + { SECURITY_DESCRIPTOR *sdPtr = NULL; unsigned long size; PSID pSid = 0; @@ -1704,11 +1670,11 @@ NativeAccess( int error; /* - * First find out how big the buffer needs to be + * First find out how big the buffer needs to be. */ size = 0; - (*tclWinProcs->getFileSecurityProc)(nativePath, + GetFileSecurity(nativePath, OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION | LABEL_SECURITY_INFORMATION, 0, 0, &size); @@ -1742,7 +1708,7 @@ NativeAccess( * Call GetFileSecurity() for real. */ - if (!(*tclWinProcs->getFileSecurityProc)(nativePath, + if (!GetFileSecurity(nativePath, OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION | LABEL_SECURITY_INFORMATION, sdPtr, size, &size)) { @@ -1778,14 +1744,14 @@ NativeAccess( * thread token. */ - if (!(*tclWinProcs->impersonateSelfProc)(SecurityImpersonation)) { + if (!ImpersonateSelf(SecurityImpersonation)) { /* * Unable to perform security impersonation. */ goto accessError; } - if (!(*tclWinProcs->openThreadTokenProc)(GetCurrentThread(), + if (!OpenThreadToken(GetCurrentThread(), TOKEN_DUPLICATE | TOKEN_QUERY, FALSE, &hToken)) { /* * Unable to get current thread's token. @@ -1794,7 +1760,7 @@ NativeAccess( goto accessError; } - (*tclWinProcs->revertToSelfProc)(); + RevertToSelf(); /* * Setup desiredAccess according to the access priveleges we are @@ -1821,7 +1787,7 @@ NativeAccess( * Perform access check using the token. */ - if (!(*tclWinProcs->accessCheckProc)(sdPtr, hToken, desiredAccess, + if (!AccessCheck(sdPtr, hToken, desiredAccess, &genMap, &privSet, &privSetSize, &grantedAccess, &accessYesNo)) { /* @@ -1851,6 +1817,7 @@ NativeAccess( } } +#endif /* !UNICODE */ return 0; } @@ -1870,60 +1837,25 @@ NativeAccess( static int NativeIsExec( - const TCHAR *nativePath) + const TCHAR *path) { - if (tclWinProcs->useWide) { - const WCHAR *path = (const WCHAR *) nativePath; - int len = wcslen(path); - - if (len < 5) { - return 0; - } - - if (path[len-4] != L'.') { - return 0; - } - - /* - * Use wide-char case-insensitive comparison - */ - - path += len-3; - if ((_wcsicmp(path, L"exe") == 0) - || (_wcsicmp(path, L"com") == 0) - || (_wcsicmp(path, L"cmd") == 0) - || (_wcsicmp(path, L"ps1") == 0) - || (_wcsicmp(path, L"bat") == 0)) { - return 1; - } - } else { - const char *p; + int len = _tcslen(path); - /* - * We are only looking for pure ascii. - */ - - p = strrchr((const char *) nativePath, '.'); - if (p != NULL) { - p++; - - /* - * Note: in the old code, stat considered '.pif' files as - * executable, whereas access did not. - */ + if (len < 5) { + return 0; + } - if ((strcasecmp(p, "exe") == 0) - || (strcasecmp(p, "com") == 0) - || (strcasecmp(p, "cmd") == 0) - || (strcasecmp(p, "ps1") == 0) - || (strcasecmp(p, "bat") == 0)) { - /* - * File that ends with .exe, .com, or .bat is executable. - */ + if (path[len-4] != '.') { + return 0; + } - return 1; - } - } + path += len-3; + if ((_tcsicmp(path, TEXT("exe")) == 0) + || (_tcsicmp(path, TEXT("com")) == 0) + || (_tcsicmp(path, TEXT("cmd")) == 0) + || (_tcsicmp(path, TEXT("cmd")) == 0) + || (_tcsicmp(path, TEXT("bat")) == 0)) { + return 1; } return 0; } @@ -1951,12 +1883,12 @@ TclpObjChdir( int result; const TCHAR *nativePath; - nativePath = (const TCHAR *) Tcl_FSGetNativePath(pathPtr); + nativePath = Tcl_FSGetNativePath(pathPtr); if (!nativePath) { return -1; } - result = (*tclWinProcs->setCurrentDirectoryProc)(nativePath); + result = SetCurrentDirectory(nativePath); if (result == 0) { TclWinConvertError(GetLastError()); @@ -1993,14 +1925,16 @@ TclpGetCwd( Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with * name of current directory. */ { - WCHAR buffer[MAX_PATH]; + TCHAR buffer[MAX_PATH]; char *p; + WCHAR *native; - if ((*tclWinProcs->getCurrentDirectoryProc)(MAX_PATH, buffer) == 0) { + if (GetCurrentDirectory(MAX_PATH, buffer) == 0) { TclWinConvertError(GetLastError()); if (interp != NULL) { - Tcl_AppendResult(interp, "error getting working directory name: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error getting working directory name: %s", + Tcl_PosixError(interp))); } return NULL; } @@ -2009,25 +1943,12 @@ TclpGetCwd( * Watch for the weird Windows c:\\UNC syntax. */ - if (tclWinProcs->useWide) { - WCHAR *native; - - native = (WCHAR *) buffer; - if ((native[0] != '\0') && (native[1] == ':') - && (native[2] == '\\') && (native[3] == '\\')) { - native += 2; - } - Tcl_WinTCharToUtf((TCHAR *) native, -1, bufferPtr); - } else { - char *native; - - native = (char *) buffer; - if ((native[0] != '\0') && (native[1] == ':') - && (native[2] == '\\') && (native[3] == '\\')) { - native += 2; - } - Tcl_WinTCharToUtf((TCHAR *) native, -1, bufferPtr); + native = (WCHAR *) buffer; + if ((native[0] != '\0') && (native[1] == ':') + && (native[2] == '\\') && (native[3] == '\\')) { + native += 2; } + Tcl_WinTCharToUtf((TCHAR *) native, -1, bufferPtr); /* * Convert to forward slashes for easier use in scripts. @@ -2054,8 +1975,7 @@ TclpObjStat( TclWinFlushDirtyChannels(); - return NativeStat((const TCHAR *) Tcl_FSGetNativePath(pathPtr), - statPtr, 0); + return NativeStat(Tcl_FSGetNativePath(pathPtr), statPtr, 0); } /* @@ -2092,6 +2012,7 @@ NativeStat( unsigned short mode; unsigned int inode = 0; HANDLE fileHandle; + DWORD fileType = FILE_TYPE_UNKNOWN; /* * If we can use 'createFile' on this, then we can use the resulting @@ -2099,9 +2020,17 @@ NativeStat( * other attributes reading APIs. If not, then we try to fall back on the * 'getFileAttributesExProc', and if that isn't available, then on even * simpler routines. + * + * Special consideration must be given to Windows hardcoded names + * like CON, NULL, COM1, LPT1 etc. For these, we still need to + * do the CreateFile as some may not exist (e.g. there is no CON + * in wish by default). However the subsequent GetFileInformationByHandle + * will fail. We do a WinIsReserved to see if it is one of the special + * names, and if successful, mock up a BY_HANDLE_FILE_INFORMATION + * structure. */ - fileHandle = (tclWinProcs->createFileProc)(nativePath, GENERIC_READ, + fileHandle = CreateFile(nativePath, GENERIC_READ, FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE, NULL, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OPEN_REPARSE_POINT, NULL); @@ -2110,19 +2039,26 @@ NativeStat( BY_HANDLE_FILE_INFORMATION data; if (GetFileInformationByHandle(fileHandle,&data) != TRUE) { - CloseHandle(fileHandle); - Tcl_SetErrno(ENOENT); - return -1; - } - CloseHandle(fileHandle); - + fileType = GetFileType(fileHandle); + CloseHandle(fileHandle); + if (fileType != FILE_TYPE_CHAR && fileType != FILE_TYPE_DISK) { + Tcl_SetErrno(ENOENT); + return -1; + } + /* Mock up the expected structure */ + memset(&data, 0, sizeof(data)); + statPtr->st_atime = 0; + statPtr->st_mtime = 0; + statPtr->st_ctime = 0; + } else { + CloseHandle(fileHandle); + statPtr->st_atime = ToCTime(data.ftLastAccessTime); + statPtr->st_mtime = ToCTime(data.ftLastWriteTime); + statPtr->st_ctime = ToCTime(data.ftCreationTime); + } attr = data.dwFileAttributes; - statPtr->st_size = ((Tcl_WideInt) data.nFileSizeLow) | (((Tcl_WideInt) data.nFileSizeHigh) << 32); - statPtr->st_atime = ToCTime(data.ftLastAccessTime); - statPtr->st_mtime = ToCTime(data.ftLastWriteTime); - statPtr->st_ctime = ToCTime(data.ftCreationTime); /* * On Unix, for directories, nlink apparently depends on the number of @@ -2141,24 +2077,24 @@ NativeStat( */ inode = data.nFileIndexHigh | data.nFileIndexLow; - } else if (tclWinProcs->getFileAttributesExProc != NULL) { + } else { /* * Fall back on the less capable routines. This means no nlink or ino. */ WIN32_FILE_ATTRIBUTE_DATA data; - if ((*tclWinProcs->getFileAttributesExProc)(nativePath, + if (GetFileAttributesEx(nativePath, GetFileExInfoStandard, &data) != TRUE) { HANDLE hFind; - WIN32_FIND_DATAT ffd; + WIN32_FIND_DATA ffd; DWORD lasterror = GetLastError(); if (lasterror != ERROR_SHARING_VIOLATION) { TclWinConvertError(lasterror); return -1; } - hFind = (*tclWinProcs->findFirstFileProc)(nativePath, &ffd); + hFind = FindFirstFile(nativePath, &ffd); if (hFind == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); return -1; @@ -2174,50 +2110,17 @@ NativeStat( statPtr->st_atime = ToCTime(data.ftLastAccessTime); statPtr->st_mtime = ToCTime(data.ftLastWriteTime); statPtr->st_ctime = ToCTime(data.ftCreationTime); - } else { - /* - * We don't have the faster attributes proc, so we're probably running - * on Win95. - */ - - WIN32_FIND_DATAT data; - HANDLE handle; - - handle = (*tclWinProcs->findFirstFileProc)(nativePath, &data); - if (handle == INVALID_HANDLE_VALUE) { - /* - * FindFirstFile() doesn't work on root directories, so call - * GetFileAttributes() to see if the specified file exists. - */ - - attr = (*tclWinProcs->getFileAttributesProc)(nativePath); - if (attr == INVALID_FILE_ATTRIBUTES) { - Tcl_SetErrno(ENOENT); - return -1; - } - - /* - * Make up some fake information for this file. It has the correct - * file attributes and a time of 0. - */ - - memset(&data, 0, sizeof(data)); - data.a.dwFileAttributes = attr; - } else { - FindClose(handle); - } - - attr = data.a.dwFileAttributes; - - statPtr->st_size = ((Tcl_WideInt) data.a.nFileSizeLow) | - (((Tcl_WideInt) data.a.nFileSizeHigh) << 32); - statPtr->st_atime = ToCTime(data.a.ftLastAccessTime); - statPtr->st_mtime = ToCTime(data.a.ftLastWriteTime); - statPtr->st_ctime = ToCTime(data.a.ftCreationTime); } dev = NativeDev(nativePath); mode = NativeStatMode(attr, checkLinks, NativeIsExec(nativePath)); + if (fileType == FILE_TYPE_CHAR) { + mode &= ~S_IFMT; + mode |= S_IFCHR; + } else if (fileType == FILE_TYPE_DISK) { + mode &= ~S_IFMT; + mode |= S_IFBLK; + } statPtr->st_dev = (dev_t) dev; statPtr->st_ino = inode; @@ -2245,14 +2148,12 @@ NativeDev( { int dev; Tcl_DString ds; - WCHAR nativeFullPath[MAX_PATH]; + TCHAR nativeFullPath[MAX_PATH]; TCHAR *nativePart; const char *fullPath; - (*tclWinProcs->getFullPathNameProc)(nativePath, MAX_PATH, - nativeFullPath, &nativePart); - - fullPath = Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds); + GetFullPathName(nativePath, MAX_PATH, nativeFullPath, &nativePart); + fullPath = Tcl_WinTCharToUtf(nativeFullPath, -1, &ds); if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) { const char *p; @@ -2268,15 +2169,14 @@ NativeDev( * won't work. */ - fullPath = Tcl_DStringAppend(&ds, "\\", 1); + fullPath = TclDStringAppendLiteral(&ds, "\\"); p = fullPath + Tcl_DStringLength(&ds); } else { p++; } nativeVol = Tcl_WinUtfToTChar(fullPath, p - fullPath, &volString); dw = (DWORD) -1; - (*tclWinProcs->getVolumeInformationProc)(nativeVol, NULL, 0, &dw, - NULL, NULL, NULL, 0); + GetVolumeInformation(nativeVol, NULL, 0, &dw, NULL, NULL, NULL, 0); /* * GetFullPathName() turns special devices like "NUL" into "\\.\NUL", @@ -2388,8 +2288,9 @@ FromCTime( FILETIME *fileTime) /* UTC Time */ { LARGE_INTEGER convertedTime; + convertedTime.QuadPart = ((LONGLONG) posixTime) * 10000000 - + POSIX_EPOCH_AS_FILETIME; + + POSIX_EPOCH_AS_FILETIME; fileTime->dwLowDateTime = convertedTime.LowPart; fileTime->dwHighDateTime = convertedTime.HighPart; } @@ -2419,34 +2320,20 @@ ClientData TclpGetNativeCwd( ClientData clientData) { - WCHAR buffer[MAX_PATH]; + TCHAR buffer[MAX_PATH]; - if ((*tclWinProcs->getCurrentDirectoryProc)(MAX_PATH, buffer) == 0) { + if (GetCurrentDirectory(MAX_PATH, buffer) == 0) { TclWinConvertError(GetLastError()); return NULL; } if (clientData != NULL) { - if (tclWinProcs->useWide) { - /* - * Unicode representation when running on NT/2K/XP. - */ - - if (wcscmp((const WCHAR*)clientData, (const WCHAR*)buffer) == 0) { - return clientData; - } - } else { - /* - * ANSI representation when running on 95/98/ME. - */ - - if (strcmp((const char*) clientData, (const char*) buffer) == 0) { - return clientData; - } + if (_tcscmp((const TCHAR*)clientData, buffer) == 0) { + return clientData; } } - return TclNativeDupInternalRep((ClientData) buffer); + return TclNativeDupInternalRep(buffer); } int @@ -2454,7 +2341,7 @@ TclpObjAccess( Tcl_Obj *pathPtr, int mode) { - return NativeAccess((const TCHAR *) Tcl_FSGetNativePath(pathPtr), mode); + return NativeAccess(Tcl_FSGetNativePath(pathPtr), mode); } int @@ -2470,8 +2357,7 @@ TclpObjLstat( TclWinFlushDirtyChannels(); - return NativeStat((const TCHAR *) Tcl_FSGetNativePath(pathPtr), - statPtr, 1); + return NativeStat(Tcl_FSGetNativePath(pathPtr), statPtr, 1); } #ifdef S_IFLNK @@ -2483,15 +2369,15 @@ TclpObjLink( { if (toPtr != NULL) { int res; - TCHAR *LinkTarget; - TCHAR *LinkSource = (TCHAR *) Tcl_FSGetNativePath(pathPtr); + const TCHAR *LinkTarget; + const TCHAR *LinkSource = Tcl_FSGetNativePath(pathPtr); Tcl_Obj *normalizedToPtr = Tcl_FSGetNormalizedPath(NULL, toPtr); if (normalizedToPtr == NULL) { return NULL; } - LinkTarget = (TCHAR *) Tcl_FSGetNativePath(normalizedToPtr); + LinkTarget = Tcl_FSGetNativePath(normalizedToPtr); if (LinkSource == NULL || LinkTarget == NULL) { return NULL; @@ -2503,7 +2389,7 @@ TclpObjLink( return NULL; } } else { - TCHAR *LinkSource = (TCHAR *) Tcl_FSGetNativePath(pathPtr); + const TCHAR *LinkSource = Tcl_FSGetNativePath(pathPtr); if (LinkSource == NULL) { return NULL; @@ -2511,7 +2397,7 @@ TclpObjLink( return WinReadLink(LinkSource); } } -#endif +#endif /* S_IFLNK */ /* *--------------------------------------------------------------------------- @@ -2537,7 +2423,7 @@ TclpFilesystemPathType( { #define VOL_BUF_SIZE 32 int found; - WCHAR volType[VOL_BUF_SIZE]; + TCHAR volType[VOL_BUF_SIZE]; char *firstSeparator; const char *path; Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr); @@ -2552,16 +2438,14 @@ TclpFilesystemPathType( firstSeparator = strchr(path, '/'); if (firstSeparator == NULL) { - found = tclWinProcs->getVolumeInformationProc( - Tcl_FSGetNativePath(pathPtr), NULL, 0, NULL, NULL, NULL, - (WCHAR *) volType, VOL_BUF_SIZE); + found = GetVolumeInformation(Tcl_FSGetNativePath(pathPtr), + NULL, 0, NULL, NULL, NULL, volType, VOL_BUF_SIZE); } else { Tcl_Obj *driveName = Tcl_NewStringObj(path, firstSeparator - path+1); Tcl_IncrRefCount(driveName); - found = tclWinProcs->getVolumeInformationProc( - Tcl_FSGetNativePath(driveName), NULL, 0, NULL, NULL, NULL, - (WCHAR *) volType, VOL_BUF_SIZE); + found = GetVolumeInformation(Tcl_FSGetNativePath(driveName), + NULL, 0, NULL, NULL, NULL, volType, VOL_BUF_SIZE); Tcl_DecrRefCount(driveName); } @@ -2569,13 +2453,9 @@ TclpFilesystemPathType( return NULL; } else { Tcl_DString ds; - Tcl_Obj *objPtr; - Tcl_WinTCharToUtf((const char *) volType, -1, &ds); - objPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), - Tcl_DStringLength(&ds)); - Tcl_DStringFree(&ds); - return objPtr; + Tcl_WinTCharToUtf(volType, -1, &ds); + return TclDStringToObj(&ds); } #undef VOL_BUF_SIZE } @@ -2625,377 +2505,219 @@ TclpObjNormalizePath( Tcl_DString dsNorm; /* This will hold the normalized string. */ char *path, *currentPathEndPosition; Tcl_Obj *temp = NULL; + int isDrive = 1; + Tcl_DString ds; /* Some workspace. */ Tcl_DStringInit(&dsNorm); path = Tcl_GetString(pathPtr); - if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_WINDOWS) { - /* - * We're on Win95, 98 or ME. There are two assumptions in this block - * of code. First that the native (NULL) encoding is basically ascii, - * and second that symbolic links are not possible. Both of these - * assumptions appear to be true of these operating systems. - */ - - int isDrive = 1; - Tcl_DString ds; - - currentPathEndPosition = path + nextCheckpoint; - if (*currentPathEndPosition == '/') { - currentPathEndPosition++; - } - - while (1) { - char cur = *currentPathEndPosition; + currentPathEndPosition = path + nextCheckpoint; + if (*currentPathEndPosition == '/') { + currentPathEndPosition++; + } + while (1) { + char cur = *currentPathEndPosition; - if ((cur=='/' || cur==0) && (path != currentPathEndPosition)) { - /* - * Reached directory separator, or end of string. - */ + if ((cur=='/' || cur==0) && (path != currentPathEndPosition)) { + /* + * Reached directory separator, or end of string. + */ - const char *nativePath = Tcl_UtfToExternalDString(NULL, path, - currentPathEndPosition - path, &ds); + WIN32_FILE_ATTRIBUTE_DATA data; + const TCHAR *nativePath = Tcl_WinUtfToTChar(path, + currentPathEndPosition - path, &ds); + if (GetFileAttributesEx(nativePath, + GetFileExInfoStandard, &data) != TRUE) { /* - * Now we convert the tail of the current path to its 'long - * form', and append it to 'dsNorm' which holds the current - * normalized path, if the file exists. + * File doesn't exist. */ if (isDrive) { - if (GetFileAttributesA(nativePath) - == INVALID_FILE_ATTRIBUTES) { - /* - * File doesn't exist. - */ - - if (isDrive) { - int len = WinIsReserved(path); - - if (len > 0) { - /* - * Actually it does exist - COM1, etc. - */ - - int i; - - for (i=0 ; i<len ; i++) { - if (nativePath[i] >= 'a') { - ((char *) nativePath)[i] -= ('a'-'A'); - } - } - Tcl_DStringAppend(&dsNorm, nativePath, len); - lastValidPathEnd = currentPathEndPosition; - } else if (nextCheckpoint == 0) { - /* Path starts with a drive designation - * that's not actually on the system. - * We still must normalize up past the - * first separator. [Bug 3603434] */ - currentPathEndPosition++; - } - } - Tcl_DStringFree(&ds); - break; - } - if (nativePath[0] >= 'a') { - ((char *) nativePath)[0] -= ('a' - 'A'); - } - Tcl_DStringAppend(&dsNorm, nativePath, - Tcl_DStringLength(&ds)); - } else { - char *checkDots = NULL; - - if (lastValidPathEnd[1] == '.') { - checkDots = lastValidPathEnd + 1; - while (checkDots < currentPathEndPosition) { - if (*checkDots != '.') { - checkDots = NULL; - break; - } - checkDots++; - } - } - if (checkDots != NULL) { - int dotLen = currentPathEndPosition-lastValidPathEnd; - - /* - * 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 - */ + int len = WinIsReserved(path); - Tcl_DStringAppend(&dsNorm, (TCHAR *) - (nativePath + Tcl_DStringLength(&ds)-dotLen), - dotLen); - } else { + if (len > 0) { /* - * Normal path. + * Actually it does exist - COM1, etc. */ - WIN32_FIND_DATA fData; - HANDLE handle; + int i; - handle = FindFirstFileA(nativePath, &fData); - if (handle == INVALID_HANDLE_VALUE) { - if (GetFileAttributesA(nativePath) - == INVALID_FILE_ATTRIBUTES) { - /* - * File doesn't exist. - */ + for (i=0 ; i<len ; i++) { + WCHAR wc = ((WCHAR *) nativePath)[i]; - Tcl_DStringFree(&ds); - break; + if (wc >= L'a') { + wc -= (L'a' - L'A'); + ((WCHAR *) nativePath)[i] = wc; } - - /* - * 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); - lastValidPathEnd = currentPathEndPosition; - if (cur == 0) { - break; - } - - /* - * If we get here, we've got past one directory delimiter, so - * we know it is no longer a drive. - */ - - isDrive = 0; + break; } - currentPathEndPosition++; - } - } else { - /* - * We're on WinNT (or 2000 or XP; something with an NT core). - */ - int isDrive = 1; - Tcl_DString ds; - - currentPathEndPosition = path + nextCheckpoint; - if (*currentPathEndPosition == '/') { - currentPathEndPosition++; - } - while (1) { - char cur = *currentPathEndPosition; + /* + * File 'nativePath' does exist if we get here. We now want to + * check if it is a symlink and otherwise continue with the + * rest of the path. + */ - if ((cur=='/' || cur==0) && (path != currentPathEndPosition)) { - /* - * Reached directory separator, or end of string. - */ + /* + * Check for symlinks, except at last component of path (we + * don't follow final symlinks). Also a drive (C:/) for + * example, may sometimes have the reparse flag set for some + * reason I don't understand. We therefore don't perform this + * check for drives. + */ - WIN32_FILE_ATTRIBUTE_DATA data; - const char *nativePath = Tcl_WinUtfToTChar(path, - currentPathEndPosition - path, &ds); + if (cur != 0 && !isDrive && + data.dwFileAttributes & FILE_ATTRIBUTE_REPARSE_POINT){ + Tcl_Obj *to = WinReadLinkDirectory(nativePath); - if ((*tclWinProcs->getFileAttributesExProc)(nativePath, - GetFileExInfoStandard, &data) != TRUE) { + if (to != NULL) { /* - * File doesn't exist. + * Read the reparse point ok. Now, reparse points need + * not be normalized, otherwise we could use: + * + * Tcl_GetStringFromObj(to, &pathLen); + * nextCheckpoint = pathLen; + * + * So, instead we have to start from the beginning. */ - if (isDrive) { - int len = WinIsReserved(path); - - if (len > 0) { - /* - * Actually it does exist - COM1, etc. - */ + nextCheckpoint = 0; + Tcl_AppendToObj(to, currentPathEndPosition, -1); - int i; - - for (i=0 ; i<len ; i++) { - WCHAR wc = ((WCHAR *) nativePath)[i]; + /* + * Convert link to forward slashes. + */ - if (wc >= L'a') { - wc -= (L'a' - L'A'); - ((WCHAR *) nativePath)[i] = wc; - } - } - Tcl_DStringAppend(&dsNorm, nativePath, - (int)(sizeof(WCHAR) * len)); - lastValidPathEnd = currentPathEndPosition; - } else if (nextCheckpoint == 0) { - /* Path starts with a drive designation - * that's not actually on the system. - * We still must normalize up past the - * first separator. [Bug 3603434] */ - currentPathEndPosition++; + for (path = Tcl_GetString(to); *path != 0; path++) { + if (*path == '\\') { + *path = '/'; } } - Tcl_DStringFree(&ds); - break; - } - - /* - * File 'nativePath' does exist if we get here. We now want to - * check if it is a symlink and otherwise continue with the - * rest of the path. - */ - - /* - * Check for symlinks, except at last component of path (we - * don't follow final symlinks). Also a drive (C:/) for - * example, may sometimes have the reparse flag set for some - * reason I don't understand. We therefore don't perform this - * check for drives. - */ + path = Tcl_GetString(to); + currentPathEndPosition = path + nextCheckpoint; + if (temp != NULL) { + Tcl_DecrRefCount(temp); + } + temp = to; - if (cur != 0 && !isDrive && - data.dwFileAttributes & FILE_ATTRIBUTE_REPARSE_POINT){ - Tcl_Obj *to = WinReadLinkDirectory(nativePath); + /* + * Reset variables so we can restart normalization. + */ - if (to != NULL) { - /* - * Read the reparse point ok. Now, reparse points need - * not be normalized, otherwise we could use: - * - * Tcl_GetStringFromObj(to, &pathLen); - * nextCheckpoint = pathLen - * - * So, instead we have to start from the beginning. - */ + isDrive = 1; + Tcl_DStringFree(&dsNorm); + Tcl_DStringFree(&ds); + continue; + } + } - nextCheckpoint = 0; - Tcl_AppendToObj(to, currentPathEndPosition, -1); +#ifndef TclNORM_LONG_PATH + /* + * Now we convert the tail of the current path to its 'long + * form', and append it to 'dsNorm' which holds the current + * normalized path + */ - /* - * Convert link to forward slashes. - */ + if (isDrive) { + WCHAR drive = ((WCHAR *) nativePath)[0]; - for (path = Tcl_GetString(to); *path != 0; path++) { - if (*path == '\\') { - *path = '/'; - } - } - path = Tcl_GetString(to); - currentPathEndPosition = path + nextCheckpoint; - if (temp != NULL) { - Tcl_DecrRefCount(temp); + if (drive >= L'a') { + drive -= (L'a' - L'A'); + ((WCHAR *) nativePath)[0] = drive; + } + Tcl_DStringAppend(&dsNorm, (const char *)nativePath, + Tcl_DStringLength(&ds)); + } else { + char *checkDots = NULL; + + if (lastValidPathEnd[1] == '.') { + checkDots = lastValidPathEnd + 1; + while (checkDots < currentPathEndPosition) { + if (*checkDots != '.') { + checkDots = NULL; + break; } - temp = to; - - /* - * Reset variables so we can restart normalization. - */ - - isDrive = 1; - Tcl_DStringFree(&dsNorm); - Tcl_DStringInit(&dsNorm); - Tcl_DStringFree(&ds); - continue; + checkDots++; } } + if (checkDots != NULL) { + int dotLen = currentPathEndPosition-lastValidPathEnd; -#ifndef TclNORM_LONG_PATH - /* - * Now we convert the tail of the current path to its 'long - * form', and append it to 'dsNorm' which holds the current - * normalized path - */ + /* + * Path is just dots. We shouldn't really ever see a + * path like that. However, to be nice we at least + * don't mangle the path - we just add the dots as a + * path segment and continue. + */ - if (isDrive) { - WCHAR drive = ((WCHAR *) nativePath)[0]; - if (drive >= L'a') { - drive -= (L'a' - L'A'); - ((WCHAR *) nativePath)[0] = drive; - } - Tcl_DStringAppend(&dsNorm, nativePath, - Tcl_DStringLength(&ds)); + Tcl_DStringAppend(&dsNorm, ((const char *)nativePath) + + Tcl_DStringLength(&ds) + - (dotLen * sizeof(TCHAR)), + (int)(dotLen * sizeof(TCHAR))); } else { - char *checkDots = NULL; - - if (lastValidPathEnd[1] == '.') { - checkDots = lastValidPathEnd + 1; - while (checkDots < currentPathEndPosition) { - if (*checkDots != '.') { - checkDots = NULL; - break; - } - checkDots++; - } - } - if (checkDots != NULL) { - int dotLen = currentPathEndPosition-lastValidPathEnd; + /* + * Normal path. + */ - /* - * Path is just dots. We shouldn't really ever see a - * path like that. However, to be nice we at least - * don't mangle the path - we just add the dots as a - * path segment and continue. - */ + WIN32_FIND_DATAW fData; + HANDLE handle; - Tcl_DStringAppend(&dsNorm, (TCHAR *) - ((WCHAR*)(nativePath + Tcl_DStringLength(&ds)) - - dotLen), (int)(dotLen * sizeof(WCHAR))); - } else { + handle = FindFirstFileW((WCHAR *) nativePath, &fData); + if (handle == INVALID_HANDLE_VALUE) { /* - * Normal path. + * This is usually the '/' in 'c:/' at end of + * string. */ - WIN32_FIND_DATAW fData; - HANDLE handle; - - handle = FindFirstFileW((WCHAR *) nativePath, &fData); - if (handle == INVALID_HANDLE_VALUE) { - /* - * This is usually the '/' in 'c:/' at end of - * string. - */ + Tcl_DStringAppend(&dsNorm, (const char *) L"/", + sizeof(WCHAR)); + } else { + WCHAR *nativeName; - Tcl_DStringAppend(&dsNorm, (const char *) L"/", - sizeof(WCHAR)); + if (fData.cFileName[0] != '\0') { + nativeName = fData.cFileName; } else { - WCHAR *nativeName; - - if (fData.cFileName[0] != '\0') { - nativeName = fData.cFileName; - } else { - nativeName = fData.cAlternateFileName; - } - FindClose(handle); - Tcl_DStringAppend(&dsNorm, (const char *) L"/", - sizeof(WCHAR)); - Tcl_DStringAppend(&dsNorm, (TCHAR *) nativeName, - (int) (wcslen(nativeName)*sizeof(WCHAR))); + nativeName = fData.cAlternateFileName; } + FindClose(handle); + Tcl_DStringAppend(&dsNorm, (const char *) L"/", + sizeof(WCHAR)); + Tcl_DStringAppend(&dsNorm, + (const char *) nativeName, + (int) (wcslen(nativeName)*sizeof(WCHAR))); } } -#endif - Tcl_DStringFree(&ds); - lastValidPathEnd = currentPathEndPosition; - if (cur == 0) { - break; - } + } +#endif /* !TclNORM_LONG_PATH */ + Tcl_DStringFree(&ds); + lastValidPathEnd = currentPathEndPosition; + if (cur == 0) { + break; + } - /* - * If we get here, we've got past one directory delimiter, so - * we know it is no longer a drive. - */ + /* + * If we get here, we've got past one directory delimiter, so + * we know it is no longer a drive. + */ - isDrive = 0; - } - currentPathEndPosition++; + isDrive = 0; } + currentPathEndPosition++; #ifdef TclNORM_LONG_PATH /* @@ -3004,10 +2726,10 @@ TclpObjNormalizePath( if (1) { WCHAR wpath[MAX_PATH]; - const char *nativePath = + const TCHAR *nativePath = Tcl_WinUtfToTChar(path, lastValidPathEnd - path, &ds); - DWORD wpathlen = (*tclWinProcs->getLongPathNameProc)( - nativePath, (TCHAR *) wpath, MAX_PATH); + DWORD wpathlen = GetLongPathNameProc(nativePath, + (TCHAR *) wpath, MAX_PATH); /* * We have to make the drive letter uppercase. @@ -3016,10 +2738,11 @@ TclpObjNormalizePath( if (wpath[0] >= L'a') { wpath[0] -= (L'a' - L'A'); } - Tcl_DStringAppend(&dsNorm, (TCHAR*)wpath, wpathlen*sizeof(WCHAR)); + Tcl_DStringAppend(&dsNorm, (const char *) wpath, + wpathlen * sizeof(WCHAR)); Tcl_DStringFree(&ds); } -#endif +#endif /* TclNORM_LONG_PATH */ } /* @@ -3034,11 +2757,9 @@ TclpObjNormalizePath( * native encoding, so we have to convert it to Utf. */ - Tcl_DString dsTemp; - - Tcl_WinTCharToUtf(Tcl_DStringValue(&dsNorm), - Tcl_DStringLength(&dsNorm), &dsTemp); - nextCheckpoint = Tcl_DStringLength(&dsTemp); + Tcl_WinTCharToUtf((const TCHAR *) Tcl_DStringValue(&dsNorm), + Tcl_DStringLength(&dsNorm), &ds); + nextCheckpoint = Tcl_DStringLength(&ds); if (*lastValidPathEnd != 0) { /* * Not the end of the string. @@ -3048,7 +2769,7 @@ TclpObjNormalizePath( char *path; Tcl_Obj *tmpPathPtr; - tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsTemp), + tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), nextCheckpoint); Tcl_AppendToObj(tmpPathPtr, lastValidPathEnd, -1); path = Tcl_GetStringFromObj(tmpPathPtr, &len); @@ -3059,10 +2780,9 @@ TclpObjNormalizePath( * End of string was reached above. */ - Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&dsTemp), - nextCheckpoint); + Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&ds), nextCheckpoint); } - Tcl_DStringFree(&dsTemp); + Tcl_DStringFree(&ds); } Tcl_DStringFree(&dsNorm); @@ -3074,6 +2794,7 @@ TclpObjNormalizePath( if (temp != NULL) { Tcl_DecrRefCount(temp); } + return nextCheckpoint; } @@ -3213,7 +2934,7 @@ TclpNativeToNormalized( int len; char *copy, *p; - Tcl_WinTCharToUtf((const char *) clientData, -1, &ds); + Tcl_WinTCharToUtf((const TCHAR *) clientData, -1, &ds); copy = Tcl_DStringValue(&ds); len = Tcl_DStringLength(&ds); @@ -3269,10 +2990,11 @@ ClientData TclNativeCreateNativeRep( Tcl_Obj *pathPtr) { - char *nativePathPtr, *str; - Tcl_DString ds; + WCHAR *nativePathPtr = NULL; + const char *str; Tcl_Obj *validPathPtr; - int len; + size_t len; + WCHAR *wp; if (TclFSCwdIsNative()) { /* @@ -3285,6 +3007,7 @@ TclNativeCreateNativeRep( if (validPathPtr == NULL) { return NULL; } + /* refCount of validPathPtr was already incremented in Tcl_FSGetTranslatedPath */ } else { /* * Make sure the normalized path is set. @@ -3294,87 +3017,86 @@ TclNativeCreateNativeRep( if (validPathPtr == NULL) { return NULL; } + /* validPathPtr returned from Tcl_FSGetNormalizedPath is owned by Tcl, so incr refCount here */ Tcl_IncrRefCount(validPathPtr); } - str = Tcl_GetStringFromObj(validPathPtr, &len); - Tcl_WinUtfToTChar(str, len, &ds); - if (tclWinProcs->useWide) { - WCHAR *wp = (WCHAR *) Tcl_DStringValue(&ds); - /* For a reserved device, strip a possible postfix ':' */ - len = WinIsReserved(str); - /* For normal devices */ - if (len == 0) len = Tcl_DStringLength(&ds)>>1; - /* - ** If path starts with "//?/" or "\\?\" (extended path), translate - ** any slashes to backslashes but accept the '?' as being valid. - */ - if ((str[0]=='\\' || str[0]=='/') && (str[1]=='\\' || str[1]=='/') - && str[2]=='?' && (str[3]=='\\' || str[3]=='/')) { - wp[0] = wp[1] = wp[3] = '\\'; - str += 4; - wp += 4; - len -= 4; - } - /* - ** If there is a drive prefix, the ':' must be considered valid. - **/ - if (((str[0]>='A'&&str[0]<='Z') || (str[0]>='a'&&str[0]<='z')) - && str[1]==':') { - wp += 2; - len -= 2; - } - while (len-->0) { - if ((*wp < ' ') || wcschr(L"\"*:<>?|", *wp)) { - Tcl_DecrRefCount(validPathPtr); - Tcl_DStringFree(&ds); - return NULL; - } else if (*wp=='/') { - *wp = '\\'; - } - ++wp; + str = Tcl_GetString(validPathPtr); + len = validPathPtr->length; + + if (strlen(str)!=(unsigned int)len) { + /* String contains NUL-bytes. This is invalid. */ + goto done; + } + /* For a reserved device, strip a possible postfix ':' */ + len = WinIsReserved(str); + if (len == 0) { + /* Let MultiByteToWideChar check for other invalid sequences, like + * 0xC0 0x80 (== overlong NUL). See bug [3118489]: NUL in filenames */ + len = MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, 0, 0); + if (len==0) { + goto done; } - len = Tcl_DStringLength(&ds) + sizeof(WCHAR); - } else { - char *p = Tcl_DStringValue(&ds); - len = Tcl_DStringLength(&ds); - /* - ** If path starts with "//?/" or "\\?\" (extended path), translate - ** any slashes to backslashes but accept the '?' as being valid. - */ - if ((str[0]=='\\' || str[0]=='/') && (str[1]=='\\' || str[1]=='/') - && str[2]=='?' && (str[3]=='\\' || str[3]=='/')) { - p[0] = p[1] = p[3] = '\\'; - str += 4; - p += 4; - len -= 4; + } + /* Overallocate 6 chars, making some room for extended paths */ + wp = nativePathPtr = ckalloc( (len+6) * sizeof(WCHAR) ); + if (nativePathPtr==0) { + goto done; + } + MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, nativePathPtr, len+1); + /* + ** If path starts with "//?/" or "\\?\" (extended path), translate + ** any slashes to backslashes but leave the '?' intact + */ + if ((str[0]=='\\' || str[0]=='/') && (str[1]=='\\' || str[1]=='/') + && str[2]=='?' && (str[3]=='\\' || str[3]=='/')) { + wp[0] = wp[1] = wp[3] = '\\'; + str += 4; + wp += 4; + } + /* + ** If there is no "\\?\" prefix but there is a drive or UNC + ** path prefix and the path is larger than MAX_PATH chars, + ** no Win32 API function can handle that unless it is + ** prefixed with the extended path prefix. See: + ** <http://msdn.microsoft.com/en-us/library/aa365247(VS.85).aspx#maxpath> + **/ + if (((str[0]>='A'&&str[0]<='Z') || (str[0]>='a'&&str[0]<='z')) + && str[1]==':') { + if (wp==nativePathPtr && len>MAX_PATH && (str[2]=='\\' || str[2]=='/')) { + memmove(wp+4, wp, len*sizeof(WCHAR)); + memcpy(wp, L"\\\\?\\", 4*sizeof(WCHAR)); + wp += 4; } /* - ** If there is a drive prefix, the ':' must be considered valid. - **/ - if (((str[0]>='A'&&str[0]<='Z') || (str[0]>='a'&&str[0]<='z')) - && str[1]==':') { - p += 2; - len -= 2; - } - while (len-->0) { - if ((*p < ' ') || strchr("\"*:<>?|", *p)) { - Tcl_DecrRefCount(validPathPtr); - Tcl_DStringFree(&ds); - return NULL; - } else if (*p=='/') { - *p = '\\'; - } - ++p; + ** If (remainder of) path starts with "<drive>:", + ** leave the ':' intact. + */ + wp += 2; + } else if (wp==nativePathPtr && len>MAX_PATH + && (str[0]=='\\' || str[0]=='/') + && (str[1]=='\\' || str[1]=='/') && str[2]!='?') { + memmove(wp+6, wp, len*sizeof(WCHAR)); + memcpy(wp, L"\\\\?\\UNC", 7*sizeof(WCHAR)); + wp += 7; + } + /* + ** In the remainder of the path, translate invalid characters to + ** characters in the Unicode private use area. + */ + while (*wp != '\0') { + if ((*wp < ' ') || wcschr(L"\"*:<>?|", *wp)) { + *wp |= 0xF000; + } else if (*wp == '/') { + *wp = '\\'; } - len = Tcl_DStringLength(&ds) + sizeof(char); + ++wp; } - Tcl_DecrRefCount(validPathPtr); - nativePathPtr = ckalloc((unsigned) len); - memcpy(nativePathPtr, Tcl_DStringValue(&ds), (size_t) len); - Tcl_DStringFree(&ds); - return (ClientData) nativePathPtr; + done: + + TclDecrRefCount(validPathPtr); + return nativePathPtr; } /* @@ -3405,23 +3127,11 @@ TclNativeDupInternalRep( return NULL; } - if (tclWinProcs->useWide) { - /* - * Unicode representation when running on NT/2K/XP. - */ - - len = sizeof(WCHAR) * (wcslen((const WCHAR *) clientData) + 1); - } else { - /* - * ANSI representation when running on 95/98/ME. - */ - - len = sizeof(char) * (strlen((const char *) clientData) + 1); - } + len = sizeof(TCHAR) * (_tcslen((const TCHAR *) clientData) + 1); - copy = (char *) ckalloc(len); + copy = ckalloc(len); memcpy(copy, clientData, len); - return (ClientData) copy; + return copy; } /* @@ -3456,9 +3166,9 @@ TclpUtime( FromCTime(tval->actime, &lastAccessTime); FromCTime(tval->modtime, &lastModTime); - native = (const TCHAR *) Tcl_FSGetNativePath(pathPtr); + native = Tcl_FSGetNativePath(pathPtr); - attr = (*tclWinProcs->getFileAttributesProc)(native); + attr = GetFileAttributes(native); if (attr != INVALID_FILE_ATTRIBUTES && attr & FILE_ATTRIBUTE_DIRECTORY) { flags = FILE_FLAG_BACKUP_SEMANTICS; @@ -3469,8 +3179,8 @@ TclpUtime( * savings complications that utime gets wrong. */ - fileHandle = (tclWinProcs->createFileProc)(native, FILE_WRITE_ATTRIBUTES, - 0, NULL, OPEN_EXISTING, flags, NULL); + fileHandle = CreateFile(native, FILE_WRITE_ATTRIBUTES, 0, NULL, + OPEN_EXISTING, flags, NULL); if (fileHandle == INVALID_HANDLE_VALUE || !SetFileTime(fileHandle, NULL, &lastAccessTime, &lastModTime)) { @@ -3484,6 +3194,68 @@ TclpUtime( } /* + *--------------------------------------------------------------------------- + * + * TclWinFileOwned -- + * + * Returns 1 if the specified file exists and is owned by the current + * user and 0 otherwise. Like the Unix case, the check is made using + * the real process SID, not the effective (impersonation) one. + * + *--------------------------------------------------------------------------- + */ + +int +TclWinFileOwned( + Tcl_Obj *pathPtr) /* File whose ownership is to be checked */ +{ + const TCHAR *native; + PSID ownerSid = NULL; + PSECURITY_DESCRIPTOR secd = NULL; + HANDLE token; + LPBYTE buf = NULL; + DWORD bufsz; + int owned = 0; + + native = Tcl_FSGetNativePath(pathPtr); + + if (GetNamedSecurityInfo((LPTSTR) native, SE_FILE_OBJECT, + OWNER_SECURITY_INFORMATION, &ownerSid, + NULL, NULL, NULL, &secd) != ERROR_SUCCESS) { + /* Either not a file, or we do not have access to it in which + case we are in all likelihood not the owner */ + return 0; + } + + /* + * Getting the current process SID is a multi-step process. + * We make the assumption that if a call fails, this process is + * so underprivileged it could not possibly own anything. Normally + * a process can *always* look up its own token. + */ + if (OpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, &token)) { + /* Find out how big the buffer needs to be */ + bufsz = 0; + GetTokenInformation(token, TokenUser, NULL, 0, &bufsz); + if (bufsz) { + buf = ckalloc(bufsz); + if (GetTokenInformation(token, TokenUser, buf, bufsz, &bufsz)) { + owned = EqualSid(ownerSid, ((PTOKEN_USER) buf)->User.Sid); + } + } + CloseHandle(token); + } + + /* Free allocations and be done */ + if (secd) + LocalFree(secd); /* Also frees ownerSid */ + if (buf) + ckfree(buf); + + return (owned != 0); /* Convert non-0 to 1 */ +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/win/tclWinInit.c b/win/tclWinInit.c index 7fa2b7a..ff5327d 100644 --- a/win/tclWinInit.c +++ b/win/tclWinInit.c @@ -76,6 +76,12 @@ typedef struct { #define PROCESSOR_ARCHITECTURE_UNKNOWN 0xFFFF #endif + +/* + * Windows version dependend functions + */ +TclWinProcs tclWinProcs; + /* * The following arrays contain the human readable strings for the Windows * platform and processor values. @@ -83,12 +89,12 @@ typedef struct { #define NUMPLATFORMS 4 -static char* platforms[NUMPLATFORMS] = { +static const char *const platforms[NUMPLATFORMS] = { "Win32s", "Windows 95", "Windows NT", "Windows CE" }; #define NUMPROCESSORS 11 -static char* processors[NUMPROCESSORS] = { +static const char *const processors[NUMPROCESSORS] = { "intel", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil", "amd64", "ia32_on_win64" }; @@ -105,8 +111,13 @@ 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); + +#if TCL_UTF_MAX < 4 +static void ToUtf(const WCHAR *wSrc, char *dst); +#else +#define ToUtf(wSrc, dst) WideCharToMultiByte(CP_UTF8, 0, wSrc, -1, dst, MAX_PATH * TCL_UTF_MAX, NULL, NULL) +#endif /* *--------------------------------------------------------------------------- @@ -132,14 +143,15 @@ TclpInitPlatform(void) { WSADATA wsaData; WORD wVersionRequested = MAKEWORD(2, 2); + HMODULE handle; 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 /* @@ -150,6 +162,14 @@ TclpInitPlatform(void) TclWinInit(GetModuleHandle(NULL)); #endif + + /* + * Fill available functions depending on windows version + */ + handle = GetModuleHandle(TEXT("KERNEL32")); + tclWinProcs.cancelSynchronousIo = + (BOOL (WINAPI *)(HANDLE)) GetProcAddress(handle, + "CancelSynchronousIo"); } /* @@ -178,7 +198,7 @@ TclpInitLibraryPath( #define LIBRARY_SIZE 64 Tcl_Obj *pathPtr; char installLib[LIBRARY_SIZE]; - char *bytes; + const char *bytes; pathPtr = Tcl_NewObj(); @@ -215,7 +235,7 @@ TclpInitLibraryPath( *encodingPtr = NULL; bytes = Tcl_GetStringFromObj(pathPtr, lengthPtr); - *valuePtr = ckalloc((unsigned int)(*lengthPtr)+1); + *valuePtr = ckalloc((*lengthPtr) + 1); memcpy(*valuePtr, bytes, (size_t)(*lengthPtr)+1); Tcl_DecrRefCount(pathPtr); } @@ -242,14 +262,14 @@ TclpInitLibraryPath( static void AppendEnvironment( Tcl_Obj *pathPtr, - CONST char *lib) + const char *lib) { int pathc; WCHAR wBuf[MAX_PATH]; char buf[MAX_PATH * TCL_UTF_MAX]; Tcl_Obj *objPtr; Tcl_DString ds; - CONST char **pathv; + const char **pathv; char *shortlib; /* @@ -295,8 +315,6 @@ AppendEnvironment( */ if ((pathc > 0) && (lstrcmpiA(shortlib, pathv[pathc - 1]) != 0)) { - CONST char *str; - /* * TCL_LIBRARY is set but refers to a different tcl installation * than the current version. Try fiddling with the specified @@ -306,14 +324,13 @@ AppendEnvironment( pathv[pathc - 1] = shortlib; Tcl_DStringInit(&ds); - str = Tcl_JoinPath(pathc, pathv, &ds); - objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&ds)); - Tcl_DStringFree(&ds); + (void) Tcl_JoinPath(pathc, pathv, &ds); + objPtr = TclDStringToObj(&ds); } else { objPtr = Tcl_NewStringObj(buf, -1); } Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); - ckfree((char *) pathv); + ckfree(pathv); } } @@ -413,7 +430,7 @@ InitializeSourceLibraryDir( TclWinNoBackslash(name); sprintf(end + 1, "../library"); *lengthPtr = strlen(name); - *valuePtr = ckalloc((unsigned int) *lengthPtr + 1); + *valuePtr = ckalloc(*lengthPtr + 1); *encodingPtr = NULL; memcpy(*valuePtr, name, (size_t) *lengthPtr + 1); } @@ -423,7 +440,7 @@ InitializeSourceLibraryDir( * * ToUtf -- * - * Convert a char string to a UTF string. + * Convert a wchar string to a UTF string. * * Results: * None. @@ -434,46 +451,19 @@ InitializeSourceLibraryDir( *--------------------------------------------------------------------------- */ -static int +#if TCL_UTF_MAX < 4 +static void ToUtf( - CONST WCHAR *wSrc, + const WCHAR *wSrc, char *dst) { - char *start; - - start = dst; while (*wSrc != '\0') { dst += Tcl_UniCharToUtf(*wSrc, dst); wSrc++; } *dst = '\0'; - return (int) (dst - start); -} - -/* - *--------------------------------------------------------------------------- - * - * 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(); } +#endif /* *--------------------------------------------------------------------------- @@ -510,18 +500,13 @@ TclpSetInitialEncodings(void) Tcl_DStringFree(&encodingName); } -void -TclpSetInterfaces(void) +void TclWinSetInterfaces( + int dummy) /* Not used. */ { - int platformId, useWide; - - platformId = TclWinGetPlatformId(); - useWide = ((platformId == VER_PLATFORM_WIN32_NT) - || (platformId == VER_PLATFORM_WIN32_CE)); - TclWinSetInterfaces(useWide); + TclpSetInterfaces(); } -CONST char * +const char * Tcl_GetEncodingNameFromEnvironment( Tcl_DString *bufPtr) { @@ -540,15 +525,15 @@ TclpGetUserName( Tcl_DStringInit(bufferPtr); if (TclGetEnv("USERNAME", bufferPtr) == NULL) { - WCHAR szUserName[UNLEN+1]; + TCHAR szUserName[UNLEN+1]; DWORD cchUserNameLen = UNLEN; - if (!tclWinProcs->getUserName((LPTSTR)szUserName, &cchUserNameLen)) { + if (!GetUserName(szUserName, &cchUserNameLen)) { return NULL; } cchUserNameLen--; - if (tclWinProcs->useWide) cchUserNameLen *= sizeof(WCHAR); - Tcl_WinTCharToUtf((LPTSTR)szUserName, cchUserNameLen, bufferPtr); + cchUserNameLen *= sizeof(TCHAR); + Tcl_WinTCharToUtf(szUserName, cchUserNameLen, bufferPtr); } return Tcl_DStringValue(bufferPtr); } @@ -574,7 +559,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; @@ -617,7 +602,7 @@ TclpSetVariables( TCL_GLOBAL_ONLY); } -#ifndef NDEBUG +#ifdef _DEBUG /* * The existence of the "debug" element of the tcl_platform array * indicates that this particular Tcl shell has been compiled with debug @@ -664,6 +649,12 @@ TclpSetVariables( Tcl_SetVar2(interp, "tcl_platform", "user", ptr ? ptr : "", TCL_GLOBAL_ONLY); Tcl_DStringFree(&ds); + + /* + * Define what the platform PATH separator is. [TIP #315] + */ + + Tcl_SetVar2(interp, "tcl_platform","pathSeparator", ";", TCL_GLOBAL_ONLY); } /* @@ -672,7 +663,7 @@ TclpSetVariables( * TclpFindVariable -- * * Locate the entry in environ for a given name. On Unix this routine is - * case sensitive, on Windows this matches mioxed case. + * case sensitive, on Windows this matches mixed case. * * Results: * The return value is the index in environ of an entry with the name @@ -688,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 @@ -696,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; @@ -705,7 +696,7 @@ TclpFindVariable( */ length = strlen(name); - nameUpper = (char *) ckalloc((unsigned) length+1); + nameUpper = ckalloc(length + 1); memcpy(nameUpper, name, (size_t) length+1); Tcl_UtfToUpper(nameUpper); diff --git a/win/tclWinInt.h b/win/tclWinInt.h index af6619f..d0844da 100644 --- a/win/tclWinInt.h +++ b/win/tclWinInt.h @@ -32,12 +32,13 @@ 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. + * Windows version dependend functions */ +typedef struct TclWinProcs { + BOOL (WINAPI *cancelSynchronousIo)(HANDLE); +} TclWinProcs; -#define TCL_WIN_STACK_THRESHOLD 0x8000 +MODULE_SCOPE TclWinProcs tclWinProcs; /* * Some versions of Borland C have a define for the OSVERSIONINFO for @@ -59,124 +60,12 @@ typedef struct TCLEXCEPTION_REGISTRATION { #endif /* - * The following structure keeps track of whether we are using the - * multi-byte or the wide-character interfaces to the operating system. - * System calls should be made through the following function table. - */ - -typedef union { - WIN32_FIND_DATAA a; - WIN32_FIND_DATAW w; -} WIN32_FIND_DATAT; - -typedef struct TclWinProcs { - int useWide; - - BOOL (WINAPI *buildCommDCBProc)(CONST TCHAR *, LPDCB); - TCHAR *(WINAPI *charLowerProc)(TCHAR *); - BOOL (WINAPI *copyFileProc)(CONST TCHAR *, CONST TCHAR *, BOOL); - BOOL (WINAPI *createDirectoryProc)(CONST TCHAR *, LPSECURITY_ATTRIBUTES); - HANDLE (WINAPI *createFileProc)(CONST TCHAR *, DWORD, DWORD, - LPSECURITY_ATTRIBUTES, DWORD, DWORD, HANDLE); - BOOL (WINAPI *createProcessProc)(CONST TCHAR *, TCHAR *, - LPSECURITY_ATTRIBUTES, LPSECURITY_ATTRIBUTES, BOOL, DWORD, - LPVOID, CONST TCHAR *, LPSTARTUPINFOA, LPPROCESS_INFORMATION); - BOOL (WINAPI *deleteFileProc)(CONST TCHAR *); - HANDLE (WINAPI *findFirstFileProc)(CONST TCHAR *, WIN32_FIND_DATAT *); - BOOL (WINAPI *findNextFileProc)(HANDLE, WIN32_FIND_DATAT *); - BOOL (WINAPI *getComputerNameProc)(WCHAR *, LPDWORD); - DWORD (WINAPI *getCurrentDirectoryProc)(DWORD, WCHAR *); - DWORD (WINAPI *getFileAttributesProc)(CONST TCHAR *); - DWORD (WINAPI *getFullPathNameProc)(CONST TCHAR *, DWORD nBufferLength, - WCHAR *, TCHAR **); - DWORD (WINAPI *getModuleFileNameProc)(HMODULE, WCHAR *, int); - DWORD (WINAPI *getShortPathNameProc)(CONST TCHAR *, WCHAR *, DWORD); - UINT (WINAPI *getTempFileNameProc)(CONST TCHAR *, CONST TCHAR *, UINT, - WCHAR *); - DWORD (WINAPI *getTempPathProc)(DWORD, WCHAR *); - BOOL (WINAPI *getVolumeInformationProc)(CONST TCHAR *, WCHAR *, DWORD, - LPDWORD, LPDWORD, LPDWORD, WCHAR *, DWORD); - HINSTANCE (WINAPI *loadLibraryExProc)(CONST TCHAR *, HANDLE, DWORD); - TCHAR (WINAPI *lstrcpyProc)(WCHAR *, CONST TCHAR *); - BOOL (WINAPI *moveFileProc)(CONST TCHAR *, CONST TCHAR *); - BOOL (WINAPI *removeDirectoryProc)(CONST TCHAR *); - DWORD (WINAPI *searchPathProc)(CONST TCHAR *, CONST TCHAR *, - CONST TCHAR *, DWORD, WCHAR *, TCHAR **); - BOOL (WINAPI *setCurrentDirectoryProc)(CONST TCHAR *); - BOOL (WINAPI *setFileAttributesProc)(CONST TCHAR *, DWORD); - /* - * These two function pointers will only be set when - * Tcl_FindExecutable is called. If you don't ever call that - * function, the application will crash whenever WinTcl tries to call - * functions through these null pointers. That is not a bug in Tcl - * -- Tcl_FindExecutable is obligatory in recent Tcl releases. - */ - BOOL (WINAPI *getFileAttributesExProc)(CONST TCHAR *, - GET_FILEEX_INFO_LEVELS, LPVOID); - BOOL (WINAPI *createHardLinkProc)(CONST TCHAR*, CONST TCHAR*, - LPSECURITY_ATTRIBUTES); - - /* deleted INT (__cdecl *utimeProc)(CONST TCHAR*, struct _utimbuf *); */ - /* These two are also NULL at start; see comment above */ - HANDLE (WINAPI *findFirstFileExProc)(CONST TCHAR*, UINT, - LPVOID, UINT, - LPVOID, DWORD); - BOOL (WINAPI *getVolumeNameForVMPProc)(CONST TCHAR*, TCHAR*, DWORD); - DWORD (WINAPI *getLongPathNameProc)(CONST TCHAR*, TCHAR*, DWORD); - /* - * These six are for the security sdk to get correct file - * permissions on NT, 2000, XP, etc. On 95,98,ME they are - * always null. - */ - BOOL (WINAPI *getFileSecurityProc)(LPCTSTR lpFileName, - SECURITY_INFORMATION RequestedInformation, - PSECURITY_DESCRIPTOR pSecurityDescriptor, - DWORD nLength, - LPDWORD lpnLengthNeeded); - BOOL (WINAPI *impersonateSelfProc) (SECURITY_IMPERSONATION_LEVEL - ImpersonationLevel); - BOOL (WINAPI *openThreadTokenProc) (HANDLE ThreadHandle, - DWORD DesiredAccess, BOOL OpenAsSelf, - PHANDLE TokenHandle); - BOOL (WINAPI *revertToSelfProc) (void); - VOID (WINAPI *mapGenericMaskProc) (PDWORD AccessMask, - PGENERIC_MAPPING GenericMapping); - BOOL (WINAPI *accessCheckProc)(PSECURITY_DESCRIPTOR pSecurityDescriptor, - HANDLE ClientToken, DWORD DesiredAccess, - PGENERIC_MAPPING GenericMapping, - PPRIVILEGE_SET PrivilegeSet, - LPDWORD PrivilegeSetLength, - LPDWORD GrantedAccess, - LPBOOL AccessStatus); - /* - * Unicode console support. WriteConsole and ReadConsole - */ - BOOL (WINAPI *readConsoleProc)( - HANDLE hConsoleInput, - LPVOID lpBuffer, - DWORD nNumberOfCharsToRead, - LPDWORD lpNumberOfCharsRead, - LPVOID lpReserved - ); - BOOL (WINAPI *writeConsoleProc)( - HANDLE hConsoleOutput, - const VOID* lpBuffer, - DWORD nNumberOfCharsToWrite, - LPDWORD lpNumberOfCharsWritten, - LPVOID lpReserved - ); - BOOL (WINAPI *getUserName)(LPTSTR lpBuffer, LPDWORD lpnSize); -} TclWinProcs; - -MODULE_SCOPE TclWinProcs *tclWinProcs; - -/* * Declarations of functions that are not accessible by way of the * stubs table. */ MODULE_SCOPE char TclWinDriveLetterForVolMountPoint( - CONST WCHAR *mountPoint); + const TCHAR *mountPoint); MODULE_SCOPE void TclWinEncodingsCleanup(); MODULE_SCOPE void TclWinInit(HINSTANCE hInst); MODULE_SCOPE TclFile TclWinMakeFile(HANDLE handle); @@ -186,13 +75,13 @@ MODULE_SCOPE Tcl_Channel TclWinOpenFileChannel(HANDLE handle, char *channelName, int permissions, int appendMode); MODULE_SCOPE Tcl_Channel TclWinOpenSerialChannel(HANDLE handle, char *channelName, int permissions); -MODULE_SCOPE void TclWinResetInterfaceEncodings(); -MODULE_SCOPE HANDLE TclWinSerialOpen(HANDLE handle, CONST TCHAR *name, +MODULE_SCOPE HANDLE TclWinSerialOpen(HANDLE handle, const TCHAR *name, DWORD access); -MODULE_SCOPE int TclWinSymLinkCopyDirectory(CONST TCHAR* LinkOriginal, - CONST TCHAR* LinkCopy); -MODULE_SCOPE int TclWinSymLinkDelete(CONST TCHAR* LinkOriginal, +MODULE_SCOPE int TclWinSymLinkCopyDirectory(const TCHAR *LinkOriginal, + const TCHAR *LinkCopy); +MODULE_SCOPE int TclWinSymLinkDelete(const TCHAR *LinkOriginal, int linkOnly); +MODULE_SCOPE int TclWinFileOwned(Tcl_Obj *); #if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) MODULE_SCOPE void TclWinFreeAllocCache(void); MODULE_SCOPE void TclFreeAllocCache(void *); @@ -208,4 +97,70 @@ MODULE_SCOPE const char*TclpGetUserName(Tcl_DString *bufferPtr); #define FILE_ATTRIBUTE_REPARSE_POINT 0x00000400 #endif +/* + *---------------------------------------------------------------------- + * Declarations of helper-workers threaded facilities for a pipe based channel. + * + * Corresponding functionality provided in "tclWinPipe.c". + *---------------------------------------------------------------------- + */ + +typedef struct TclPipeThreadInfo { + HANDLE evControl; /* Auto-reset event used by the main thread to + * signal when the pipe thread should attempt + * to do read/write operation. Additionally + * used as signal to stop (state set to -1) */ + volatile LONG state; /* Indicates current state of the thread */ + ClientData clientData; /* Referenced data of the main thread */ + HANDLE evWakeUp; /* Optional wake-up event worker set by shutdown */ +} TclPipeThreadInfo; + + +/* If pipe-workers will use some tcl subsystem, we can use ckalloc without + * more overhead for finalize thread (should be executed anyway) + * + * #define _PTI_USE_CKALLOC 1 + */ + +/* + * State of the pipe-worker. + * + * State PTI_STATE_STOP possible from idle state only, worker owns TI structure. + * Otherwise PTI_STATE_END used (main thread hold ownership of the TI). + */ + +#define PTI_STATE_IDLE 0 /* idle or not yet initialzed */ +#define PTI_STATE_WORK 1 /* in work */ +#define PTI_STATE_STOP 2 /* thread should stop work (owns TI structure) */ +#define PTI_STATE_END 4 /* thread should stop work (worker is busy) */ +#define PTI_STATE_DOWN 8 /* worker is down */ + + +MODULE_SCOPE +TclPipeThreadInfo * TclPipeThreadCreateTI(TclPipeThreadInfo **pipeTIPtr, + ClientData clientData, HANDLE wakeEvent); +MODULE_SCOPE int TclPipeThreadWaitForSignal(TclPipeThreadInfo **pipeTIPtr); + +static inline void +TclPipeThreadSignal( + TclPipeThreadInfo **pipeTIPtr) +{ + TclPipeThreadInfo *pipeTI = *pipeTIPtr; + if (pipeTI) { + SetEvent(pipeTI->evControl); + } +}; + +static inline int +TclPipeThreadIsAlive( + TclPipeThreadInfo **pipeTIPtr) +{ + TclPipeThreadInfo *pipeTI = *pipeTIPtr; + return (pipeTI && pipeTI->state != PTI_STATE_DOWN); +}; + +MODULE_SCOPE int TclPipeThreadStopSignal(TclPipeThreadInfo **pipeTIPtr, HANDLE wakeEvent); +MODULE_SCOPE void TclPipeThreadStop(TclPipeThreadInfo **pipeTIPtr, HANDLE hThread); +MODULE_SCOPE void TclPipeThreadExit(TclPipeThreadInfo **pipeTIPtr); + #endif /* _TCLWININT */ diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c index c4d08e8..2946ea2 100644 --- a/win/tclWinLoad.c +++ b/win/tclWinLoad.c @@ -13,6 +13,23 @@ #include "tclWinInt.h" +/* + * Native name of the directory in the native filesystem where DLLs used in + * this process are copied prior to loading, and mutex used to protect its + * allocation. + */ + +static WCHAR *dllDirectoryName = NULL; +static Tcl_Mutex dllDirectoryNameMutex; + +/* + * Static functions defined within this file. + */ + +static void * FindSymbol(Tcl_Interp *interp, + Tcl_LoadHandle loadHandle, const char *symbol); +static int InitDLLDirectoryName(void); +static void UnloadFile(Tcl_LoadHandle loadHandle); /* *---------------------------------------------------------------------- @@ -40,13 +57,16 @@ TclpDlopen( Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded * file which will be passed back to * (*unloadProcPtr)() to unload the file. */ - Tcl_FSUnloadFileProc **unloadProcPtr) + Tcl_FSUnloadFileProc **unloadProcPtr, /* Filled with address of Tcl_FSUnloadFileProc * function which should be used for this * file. */ + int flags) { - HINSTANCE handle; - CONST TCHAR *nativeName; + HINSTANCE hInstance = NULL; + const TCHAR *nativeName; + Tcl_LoadHandle handlePtr; + DWORD firstError; /* * First try the full path the user gave us. This is particularly @@ -55,9 +75,11 @@ TclpDlopen( */ nativeName = Tcl_FSGetNativePath(pathPtr); - handle = (*tclWinProcs->loadLibraryExProc)(nativeName, NULL, - LOAD_WITH_ALTERED_SEARCH_PATH); - if (handle == NULL) { + if (nativeName != NULL) { + hInstance = LoadLibraryEx(nativeName, NULL, + LOAD_WITH_ALTERED_SEARCH_PATH); + } + if (hInstance == NULL) { /* * Let the OS loader examine the binary search path for whatever * string the user gave us which hopefully refers to a file on the @@ -65,38 +87,37 @@ TclpDlopen( */ Tcl_DString ds; - char *fileName = Tcl_GetString(pathPtr); - nativeName = Tcl_WinUtfToTChar(fileName, -1, &ds); - handle = (*tclWinProcs->loadLibraryExProc)(nativeName, NULL, + /* + * Remember the first error on load attempt to be used if the + * second load attempt below also fails. + */ + firstError = (nativeName == NULL) ? + ERROR_MOD_NOT_FOUND : GetLastError(); + + nativeName = Tcl_WinUtfToTChar(Tcl_GetString(pathPtr), -1, &ds); + hInstance = LoadLibraryEx(nativeName, NULL, LOAD_WITH_ALTERED_SEARCH_PATH); Tcl_DStringFree(&ds); } - *loadHandle = (Tcl_LoadHandle) handle; + if (hInstance == NULL) { + DWORD lastError; + Tcl_Obj *errMsg; - if (handle == NULL) { - DWORD lastError = GetLastError(); + /* + * We choose to only use the error from the second call if the first + * call failed due to the file not being found. Else stick to the + * first error for reporting purposes. + */ + if (firstError == ERROR_MOD_NOT_FOUND || + firstError == ERROR_DLL_NOT_FOUND) + lastError = GetLastError(); + else + lastError = firstError; -#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); + errMsg = Tcl_ObjPrintf("couldn't load library \"%s\": ", + Tcl_GetString(pathPtr)); /* * Check for possible DLL errors. This doesn't work quite right, @@ -105,40 +126,63 @@ TclpDlopen( * better if there was a way to get what DLLs */ - switch (lastError) { - case ERROR_MOD_NOT_FOUND: - case ERROR_DLL_NOT_FOUND: - Tcl_AppendResult(interp, "this library or a dependent library" - " could not be found in library path", NULL); - break; - case ERROR_PROC_NOT_FOUND: - Tcl_AppendResult(interp, "A function specified in the import" - " table could not be resolved by the system. Windows" - " is not telling which one, I'm sorry.", NULL); - break; - case ERROR_INVALID_DLL: - Tcl_AppendResult(interp, "this library or a dependent library" - " is damaged", NULL); - break; - case ERROR_DLL_INIT_FAILED: - Tcl_AppendResult(interp, "the library initialization" - " routine failed", NULL); - break; - default: - TclWinConvertError(lastError); - Tcl_AppendResult(interp, Tcl_PosixError(interp), NULL); + if (interp) { + switch (lastError) { + case ERROR_MOD_NOT_FOUND: + Tcl_SetErrorCode(interp, "WIN_LOAD", "MOD_NOT_FOUND", NULL); + goto notFoundMsg; + case ERROR_DLL_NOT_FOUND: + Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_NOT_FOUND", NULL); + notFoundMsg: + Tcl_AppendToObj(errMsg, "this library or a dependent library" + " could not be found in library path", -1); + break; + case ERROR_PROC_NOT_FOUND: + Tcl_SetErrorCode(interp, "WIN_LOAD", "PROC_NOT_FOUND", NULL); + Tcl_AppendToObj(errMsg, "A function specified in the import" + " table could not be resolved by the system. Windows" + " is not telling which one, I'm sorry.", -1); + break; + case ERROR_INVALID_DLL: + Tcl_SetErrorCode(interp, "WIN_LOAD", "INVALID_DLL", NULL); + Tcl_AppendToObj(errMsg, "this library or a dependent library" + " is damaged", -1); + break; + case ERROR_DLL_INIT_FAILED: + Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_INIT_FAILED", NULL); + Tcl_AppendToObj(errMsg, "the library initialization" + " routine failed", -1); + break; + case ERROR_BAD_EXE_FORMAT: + Tcl_SetErrorCode(interp, "WIN_LOAD", "BAD_EXE_FORMAT", NULL); + Tcl_AppendToObj(errMsg, "Bad exe format. Possibly a 32/64-bit mismatch.", -1); + break; + default: + TclWinConvertError(lastError); + Tcl_AppendToObj(errMsg, Tcl_PosixError(interp), -1); + } + Tcl_SetObjResult(interp, errMsg); } return TCL_ERROR; - } else { - *unloadProcPtr = &TclpUnloadFile; } + + /* + * Succeded; package everything up for Tcl. + */ + + handlePtr = ckalloc(sizeof(struct Tcl_LoadHandle_)); + handlePtr->clientData = (ClientData) hInstance; + handlePtr->findSymbolProcPtr = &FindSymbol; + handlePtr->unloadFileProcPtr = &UnloadFile; + *loadHandle = handlePtr; + *unloadProcPtr = &UnloadFile; return TCL_OK; } /* *---------------------------------------------------------------------- * - * TclpFindSymbol -- + * FindSymbol -- * * Looks up a symbol, by name, through a handle associated with a * previously loaded piece of code (shared library). @@ -151,37 +195,43 @@ TclpDlopen( *---------------------------------------------------------------------- */ -Tcl_PackageInitProc * -TclpFindSymbol( +static void * +FindSymbol( Tcl_Interp *interp, Tcl_LoadHandle loadHandle, - CONST char *symbol) + const char *symbol) { + HINSTANCE hInstance = (HINSTANCE) loadHandle->clientData; Tcl_PackageInitProc *proc = NULL; - HINSTANCE handle = (HINSTANCE)loadHandle; /* * For each symbol, check for both Symbol and _Symbol, since Borland * generates C symbols with a leading '_' by default. */ - proc = (Tcl_PackageInitProc *) GetProcAddress(handle, symbol); + proc = (void *) GetProcAddress(hInstance, symbol); if (proc == NULL) { Tcl_DString ds; + const char *sym2; Tcl_DStringInit(&ds); - Tcl_DStringAppend(&ds, "_", 1); - symbol = Tcl_DStringAppend(&ds, symbol, -1); - proc = (Tcl_PackageInitProc *) GetProcAddress(handle, symbol); + TclDStringAppendLiteral(&ds, "_"); + sym2 = Tcl_DStringAppend(&ds, symbol, -1); + proc = (Tcl_PackageInitProc *) GetProcAddress(hInstance, sym2); Tcl_DStringFree(&ds); } + if (proc == NULL && interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot find symbol \"%s\"", symbol)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL); + } return proc; } /* *---------------------------------------------------------------------- * - * TclpUnloadFile -- + * UnloadFile -- * * Unloads a dynamically loaded binary code file from memory. Code * pointers in the formerly loaded file are no longer valid after calling @@ -196,16 +246,16 @@ TclpFindSymbol( *---------------------------------------------------------------------- */ -void -TclpUnloadFile( +static void +UnloadFile( Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to * TclpDlopen(). The loadHandle is a token * that represents the loaded file. */ { - HINSTANCE handle; + HINSTANCE hInstance = (HINSTANCE) loadHandle->clientData; - handle = (HINSTANCE) loadHandle; - FreeLibrary(handle); + FreeLibrary(hInstance); + ckfree(loadHandle); } /* @@ -230,7 +280,7 @@ TclpUnloadFile( int TclGuessPackageName( - CONST char *fileName, /* Name of file containing package (already + const char *fileName, /* Name of file containing package (already * translated to local form if needed). */ Tcl_DString *bufPtr) /* Initialized empty dstring. Append package * name to this if possible. */ @@ -239,6 +289,139 @@ TclGuessPackageName( } /* + *---------------------------------------------------------------------- + * + * TclpTempFileNameForLibrary -- + * + * Constructs a temporary file name for loading a shared object (DLL). + * + * Results: + * Returns the constructed file name. + * + * On Windows, a DLL is identified by the final component of its path name. + * Cross linking among DLL's (and hence, preloading) will not work unless this + * name is preserved when copying a DLL from a VFS to a temp file for + * preloading. For this reason, all DLLs in a given process are copied to a + * temp directory, and their names are preserved. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclpTempFileNameForLibrary( + Tcl_Interp *interp, /* Tcl interpreter. */ + Tcl_Obj *path) /* Path name of the DLL in the VFS. */ +{ + Tcl_Obj *fileName; /* Name of the temp file. */ + Tcl_Obj *tail; /* Tail of the source path. */ + + Tcl_MutexLock(&dllDirectoryNameMutex); + if (dllDirectoryName == NULL) { + if (InitDLLDirectoryName() == TCL_ERROR) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't create temporary directory: %s", + Tcl_PosixError(interp))); + Tcl_MutexUnlock(&dllDirectoryNameMutex); + return NULL; + } + } + Tcl_MutexUnlock(&dllDirectoryNameMutex); + + /* + * Now we know where to put temporary DLLs, construct the name. + */ + + fileName = TclpNativeToNormalized(dllDirectoryName); + tail = TclPathPart(interp, path, TCL_PATH_TAIL); + if (tail == NULL) { + Tcl_DecrRefCount(fileName); + return NULL; + } + Tcl_AppendToObj(fileName, "/", 1); + Tcl_AppendObjToObj(fileName, tail); + return fileName; +} + +/* + *---------------------------------------------------------------------- + * + * InitDLLDirectoryName -- + * + * Helper for TclpTempFileNameForLibrary; builds a temporary directory + * that is specific to the current process. Should only be called once + * per process start. Caller must hold dllDirectoryNameMutex. + * + * Results: + * Tcl result code. + * + * Side-effects: + * Creates temp directory. + * Allocates memory pointed to by dllDirectoryName. + * + *---------------------------------------------------------------------- + * [Candidate for process global?] + */ + +static int +InitDLLDirectoryName(void) +{ + size_t nameLen; /* Length of the temp folder name. */ + WCHAR name[MAX_PATH]; /* Path name of the temp folder. */ + DWORD id; /* The process id. */ + DWORD lastError; /* Last error to happen in Win API. */ + int i; + + /* + * Determine the name of the directory to use, and create it. (Keep + * trying with new names until an attempt to create the directory + * succeeds) + */ + + nameLen = GetTempPathW(MAX_PATH, name); + if (nameLen >= MAX_PATH-12) { + Tcl_SetErrno(ENAMETOOLONG); + return TCL_ERROR; + } + + wcscpy(name+nameLen, L"TCLXXXXXXXX"); + nameLen += 11; + + id = GetCurrentProcessId(); + lastError = ERROR_ALREADY_EXISTS; + + for (i=0 ; i<256 ; i++) { + wsprintfW(name+nameLen-8, L"%08x", id); + if (CreateDirectoryW(name, NULL)) { + /* + * Issue: we don't schedule this directory for deletion by anyone. + * Can we ask the OS to do this for us? There appears to be + * potential for using CreateFile (with the flag + * FILE_FLAG_BACKUP_SEMANTICS) and RemoveDirectory to do this... + */ + + goto copyToGlobalBuffer; + } + lastError = GetLastError(); + if (lastError != ERROR_ALREADY_EXISTS) { + break; + } + id *= 16777619; + } + + TclWinConvertError(lastError); + return TCL_ERROR; + + /* + * Store our computed value in the global. + */ + + copyToGlobalBuffer: + dllDirectoryName = ckalloc((nameLen+1) * sizeof(WCHAR)); + wcscpy(dllDirectoryName, name); + return TCL_OK; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/win/tclWinNotify.c b/win/tclWinNotify.c index 1cd5823..4543b02 100644 --- a/win/tclWinNotify.c +++ b/win/tclWinNotify.c @@ -42,9 +42,6 @@ typedef struct ThreadSpecificData { static Tcl_ThreadDataKey dataKey; -extern TclStubs tclStubs; -extern Tcl_NotifierProcs tclOriginalNotifier; - /* * The following static indicates the number of threads that have initialized * notifiers. It controls the lifetime of the TclNotifier window class. @@ -53,6 +50,7 @@ extern Tcl_NotifierProcs tclOriginalNotifier; */ static int notifierCount = 0; +static const TCHAR classname[] = TEXT("TclNotifier"); TCL_DECLARE_MUTEX(notifierMutex) /* @@ -81,45 +79,49 @@ static LRESULT CALLBACK NotifierProc(HWND hwnd, UINT message, ClientData Tcl_InitNotifier(void) { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - WNDCLASS class; + if (tclNotifierHooks.initNotifierProc) { + return tclNotifierHooks.initNotifierProc(); + } else { + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + WNDCLASS class; - /* - * Register Notifier window class if this is the first thread to use this - * module. - */ + /* + * Register Notifier window class if this is the first thread to use + * this module. + */ - Tcl_MutexLock(¬ifierMutex); - if (notifierCount == 0) { - class.style = 0; - class.cbClsExtra = 0; - class.cbWndExtra = 0; - class.hInstance = TclWinGetTclInstance(); - class.hbrBackground = NULL; - class.lpszMenuName = NULL; - class.lpszClassName = "TclNotifier"; - class.lpfnWndProc = NotifierProc; - class.hIcon = NULL; - class.hCursor = NULL; - - if (!RegisterClassA(&class)) { - Tcl_Panic("Unable to register TclNotifier window class"); + Tcl_MutexLock(¬ifierMutex); + if (notifierCount == 0) { + class.style = 0; + class.cbClsExtra = 0; + class.cbWndExtra = 0; + class.hInstance = TclWinGetTclInstance(); + class.hbrBackground = NULL; + class.lpszMenuName = NULL; + class.lpszClassName = classname; + class.lpfnWndProc = NotifierProc; + class.hIcon = NULL; + class.hCursor = NULL; + + if (!RegisterClass(&class)) { + Tcl_Panic("Unable to register TclNotifier window class"); + } } - } - notifierCount++; - Tcl_MutexUnlock(¬ifierMutex); + notifierCount++; + Tcl_MutexUnlock(¬ifierMutex); - tsdPtr->pending = 0; - tsdPtr->timerActive = 0; + tsdPtr->pending = 0; + tsdPtr->timerActive = 0; - InitializeCriticalSection(&tsdPtr->crit); + InitializeCriticalSection(&tsdPtr->crit); - tsdPtr->hwnd = NULL; - tsdPtr->thread = GetCurrentThreadId(); - tsdPtr->event = CreateEvent(NULL, TRUE /* manual */, - FALSE /* !signaled */, NULL); + tsdPtr->hwnd = NULL; + tsdPtr->thread = GetCurrentThreadId(); + tsdPtr->event = CreateEvent(NULL, TRUE /* manual */, + FALSE /* !signaled */, NULL); - return (ClientData) tsdPtr; + return tsdPtr; + } } /* @@ -143,46 +145,51 @@ void Tcl_FinalizeNotifier( ClientData clientData) /* Pointer to notifier data. */ { - ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; + if (tclNotifierHooks.finalizeNotifierProc) { + tclNotifierHooks.finalizeNotifierProc(clientData); + return; + } else { + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; - /* - * Only finalize the notifier if a notifier was installed in the current - * thread; there is a route in which this is not guaranteed to be true - * (when tclWin32Dll.c:DllMain() is called with the flag - * DLL_PROCESS_DETACH by the OS, which could be doing so from a thread - * that's never previously been involved with Tcl, e.g. the task manager) - * so this check is important. - * - * Fixes Bug #217982 reported by Hugh Vu and Gene Leache. - */ + /* + * Only finalize the notifier if a notifier was installed in the + * current thread; there is a route in which this is not guaranteed to + * be true (when tclWin32Dll.c:DllMain() is called with the flag + * DLL_PROCESS_DETACH by the OS, which could be doing so from a thread + * that's never previously been involved with Tcl, e.g. the task + * manager) so this check is important. + * + * Fixes Bug #217982 reported by Hugh Vu and Gene Leache. + */ - if (tsdPtr == NULL) { - return; - } + if (tsdPtr == NULL) { + return; + } - DeleteCriticalSection(&tsdPtr->crit); - CloseHandle(tsdPtr->event); + DeleteCriticalSection(&tsdPtr->crit); + CloseHandle(tsdPtr->event); - /* - * Clean up the timer and messaging window for this thread. - */ + /* + * Clean up the timer and messaging window for this thread. + */ - if (tsdPtr->hwnd) { - KillTimer(tsdPtr->hwnd, INTERVAL_TIMER); - DestroyWindow(tsdPtr->hwnd); - } + if (tsdPtr->hwnd) { + KillTimer(tsdPtr->hwnd, INTERVAL_TIMER); + DestroyWindow(tsdPtr->hwnd); + } - /* - * If this is the last thread to use the notifier, unregister the notifier - * window class. - */ + /* + * If this is the last thread to use the notifier, unregister the + * notifier window class. + */ - Tcl_MutexLock(¬ifierMutex); - notifierCount--; - if (notifierCount == 0) { - UnregisterClassA("TclNotifier", TclWinGetTclInstance()); + Tcl_MutexLock(¬ifierMutex); + notifierCount--; + if (notifierCount == 0) { + UnregisterClass(classname, TclWinGetTclInstance()); + } + Tcl_MutexUnlock(¬ifierMutex); } - Tcl_MutexUnlock(¬ifierMutex); } /* @@ -211,27 +218,32 @@ void Tcl_AlertNotifier( ClientData clientData) /* Pointer to thread data. */ { - ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; - - /* - * Note that we do not need to lock around access to the hwnd because the - * race condition has no effect since any race condition implies that the - * notifier thread is already awake. - */ + if (tclNotifierHooks.alertNotifierProc) { + tclNotifierHooks.alertNotifierProc(clientData); + return; + } else { + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; - if (tsdPtr->hwnd) { /* - * We do need to lock around access to the pending flag. + * Note that we do not need to lock around access to the hwnd because + * the race condition has no effect since any race condition implies + * that the notifier thread is already awake. */ - EnterCriticalSection(&tsdPtr->crit); - if (!tsdPtr->pending) { - PostMessage(tsdPtr->hwnd, WM_WAKEUP, 0, 0); + if (tsdPtr->hwnd) { + /* + * We do need to lock around access to the pending flag. + */ + + EnterCriticalSection(&tsdPtr->crit); + if (!tsdPtr->pending) { + PostMessage(tsdPtr->hwnd, WM_WAKEUP, 0, 0); + } + tsdPtr->pending = 1; + LeaveCriticalSection(&tsdPtr->crit); + } else { + SetEvent(tsdPtr->event); } - tsdPtr->pending = 1; - LeaveCriticalSection(&tsdPtr->crit); - } else { - SetEvent(tsdPtr->event); } } @@ -255,52 +267,47 @@ Tcl_AlertNotifier( void Tcl_SetTimer( - Tcl_Time *timePtr) /* Maximum block time, or NULL. */ + const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - UINT timeout; - - /* - * Allow the notifier to be hooked. This may not make sense on Windows, - * but mirrors the UNIX hook. - */ - - if (tclStubs.tcl_SetTimer != tclOriginalNotifier.setTimerProc) { - tclStubs.tcl_SetTimer(timePtr); - return; - } - - /* - * We only need to set up an interval timer if we're being called from an - * external event loop. If we don't have a window handle then we just - * return immediately and let Tcl_WaitForEvent handle timeouts. - */ - - if (!tsdPtr->hwnd) { + if (tclNotifierHooks.setTimerProc) { + tclNotifierHooks.setTimerProc(timePtr); return; - } - - if (!timePtr) { - timeout = 0; } else { + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + UINT timeout; + /* - * Make sure we pass a non-zero value into the timeout argument. - * Windows seems to get confused by zero length timers. + * We only need to set up an interval timer if we're being called from + * an external event loop. If we don't have a window handle then we + * just return immediately and let Tcl_WaitForEvent handle timeouts. */ - timeout = timePtr->sec * 1000 + timePtr->usec / 1000; - if (timeout == 0) { - timeout = 1; + if (!tsdPtr->hwnd) { + return; + } + + if (!timePtr) { + timeout = 0; + } else { + /* + * Make sure we pass a non-zero value into the timeout argument. + * Windows seems to get confused by zero length timers. + */ + + timeout = timePtr->sec * 1000 + timePtr->usec / 1000; + if (timeout == 0) { + timeout = 1; + } + } + tsdPtr->timeout = timeout; + if (timeout != 0) { + tsdPtr->timerActive = 1; + SetTimer(tsdPtr->hwnd, INTERVAL_TIMER, + (unsigned long) tsdPtr->timeout, NULL); + } else { + tsdPtr->timerActive = 0; + KillTimer(tsdPtr->hwnd, INTERVAL_TIMER); } - } - tsdPtr->timeout = timeout; - if (timeout != 0) { - tsdPtr->timerActive = 1; - SetTimer(tsdPtr->hwnd, INTERVAL_TIMER, (unsigned long) tsdPtr->timeout, - NULL); - } else { - tsdPtr->timerActive = 0; - KillTimer(tsdPtr->hwnd, INTERVAL_TIMER); } } @@ -326,29 +333,36 @@ Tcl_ServiceModeHook( int mode) /* Either TCL_SERVICE_ALL, or * TCL_SERVICE_NONE. */ { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - - /* - * If this is the first time that the notifier has been used from a modal - * loop, then create a communication window. Note that after this point, - * the application needs to service events in a timely fashion or Windows - * will hang waiting for the window to respond to synchronous system - * messages. At some point, we may want to consider destroying the window - * if we leave the modal loop, but for now we'll leave it around. - */ - - if (mode == TCL_SERVICE_ALL && !tsdPtr->hwnd) { - tsdPtr->hwnd = CreateWindowA("TclNotifier", "TclNotifier", WS_TILED, - 0, 0, 0, 0, NULL, NULL, TclWinGetTclInstance(), NULL); + if (tclNotifierHooks.serviceModeHookProc) { + tclNotifierHooks.serviceModeHookProc(mode); + return; + } else { + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* - * Send an initial message to the window to ensure that we wake up the - * notifier once we get into the modal loop. This will force the - * notifier to recompute the timeout value and schedule a timer if one - * is needed. + * If this is the first time that the notifier has been used from a + * modal loop, then create a communication window. Note that after this + * point, the application needs to service events in a timely fashion + * or Windows will hang waiting for the window to respond to + * synchronous system messages. At some point, we may want to consider + * destroying the window if we leave the modal loop, but for now we'll + * leave it around. */ - Tcl_AlertNotifier((ClientData)tsdPtr); + if (mode == TCL_SERVICE_ALL && !tsdPtr->hwnd) { + tsdPtr->hwnd = CreateWindow(classname, classname, + WS_TILED, 0, 0, 0, 0, NULL, NULL, TclWinGetTclInstance(), + NULL); + + /* + * Send an initial message to the window to ensure that we wake up + * the notifier once we get into the modal loop. This will force + * the notifier to recompute the timeout value and schedule a timer + * if one is needed. + */ + + Tcl_AlertNotifier(tsdPtr); + } } } @@ -416,107 +430,102 @@ NotifierProc( int Tcl_WaitForEvent( - Tcl_Time *timePtr) /* Maximum block time, or NULL. */ + const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ { - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - MSG msg; - DWORD timeout, result; - int status; - - /* - * Allow the notifier to be hooked. This may not make sense on windows, - * but mirrors the UNIX hook. - */ - - if (tclStubs.tcl_WaitForEvent != tclOriginalNotifier.waitForEventProc) { - return tclStubs.tcl_WaitForEvent(timePtr); - } - - /* - * Compute the timeout in milliseconds. - */ + if (tclNotifierHooks.waitForEventProc) { + return tclNotifierHooks.waitForEventProc(timePtr); + } else { + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + MSG msg; + DWORD timeout, result; + int status; - if (timePtr) { /* - * TIP #233 (Virtualized Time). Convert virtual domain delay to - * real-time. + * Compute the timeout in milliseconds. */ - Tcl_Time myTime; + if (timePtr) { + /* + * TIP #233 (Virtualized Time). Convert virtual domain delay to + * real-time. + */ - myTime.sec = timePtr->sec; - myTime.usec = timePtr->usec; + Tcl_Time myTime; - if (myTime.sec != 0 || myTime.usec != 0) { - (*tclScaleTimeProcPtr) (&myTime, tclTimeClientData); - } + myTime.sec = timePtr->sec; + myTime.usec = timePtr->usec; - timeout = myTime.sec * 1000 + myTime.usec / 1000; - } else { - timeout = INFINITE; - } + if (myTime.sec != 0 || myTime.usec != 0) { + tclScaleTimeProcPtr(&myTime, tclTimeClientData); + } - /* - * Check to see if there are any messages in the queue before waiting - * because MsgWaitForMultipleObjects will not wake up if there are events - * currently sitting in the queue. - */ + timeout = myTime.sec * 1000 + myTime.usec / 1000; + } else { + timeout = INFINITE; + } - if (!PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE)) { /* - * Wait for something to happen (a signal from another thread, a - * message, or timeout) or loop servicing asynchronous procedure calls - * queued to this thread. + * Check to see if there are any messages in the queue before waiting + * because MsgWaitForMultipleObjects will not wake up if there are + * events currently sitting in the queue. */ - again: - result = MsgWaitForMultipleObjectsEx(1, &tsdPtr->event, timeout, - QS_ALLINPUT, MWMO_ALERTABLE); - if (result == WAIT_IO_COMPLETION) { - goto again; - } else if (result == WAIT_FAILED) { - status = -1; - goto end; - } - } + if (!PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE)) { + /* + * Wait for something to happen (a signal from another thread, a + * message, or timeout) or loop servicing asynchronous procedure + * calls queued to this thread. + */ - /* - * Check to see if there are any messages to process. - */ + again: + result = MsgWaitForMultipleObjectsEx(1, &tsdPtr->event, timeout, + QS_ALLINPUT, MWMO_ALERTABLE); + if (result == WAIT_IO_COMPLETION) { + goto again; + } else if (result == WAIT_FAILED) { + status = -1; + goto end; + } + } - if (PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE)) { /* - * Retrieve and dispatch the first message. + * Check to see if there are any messages to process. */ - result = GetMessage(&msg, NULL, 0, 0); - if (result == 0) { - /* - * We received a request to exit this thread (WM_QUIT), so - * propagate the quit message and start unwinding. - */ - - PostQuitMessage((int) msg.wParam); - status = -1; - } else if (result == (DWORD)-1) { + if (PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE)) { /* - * We got an error from the system. I have no idea why this would - * happen, so we'll just unwind. + * Retrieve and dispatch the first message. */ - status = -1; + result = GetMessage(&msg, NULL, 0, 0); + if (result == 0) { + /* + * We received a request to exit this thread (WM_QUIT), so + * propagate the quit message and start unwinding. + */ + + PostQuitMessage((int) msg.wParam); + status = -1; + } else if (result == (DWORD)-1) { + /* + * We got an error from the system. I have no idea why this + * would happen, so we'll just unwind. + */ + + status = -1; + } else { + TranslateMessage(&msg); + DispatchMessage(&msg); + status = 1; + } } else { - TranslateMessage(&msg); - DispatchMessage(&msg); - status = 1; + status = 0; } - } else { - status = 0; - } - end: - ResetEvent(tsdPtr->event); - return status; + end: + ResetEvent(tsdPtr->event); + return status; + } } /* @@ -570,11 +579,11 @@ Tcl_Sleep( * TIP #233: Scale delay from virtual to real-time. */ - (*tclScaleTimeProcPtr) (&vdelay, tclTimeClientData); + tclScaleTimeProcPtr(&vdelay, tclTimeClientData); sleepTime = vdelay.sec * 1000 + vdelay.usec / 1000; for (;;) { - Sleep(sleepTime); + SleepEx(sleepTime, TRUE); Tcl_GetTime(&now); if (now.sec > desired.sec) { break; @@ -585,7 +594,7 @@ Tcl_Sleep( vdelay.sec = desired.sec - now.sec; vdelay.usec = desired.usec - now.usec; - (*tclScaleTimeProcPtr) (&vdelay, tclTimeClientData); + tclScaleTimeProcPtr(&vdelay, tclTimeClientData); sleepTime = vdelay.sec * 1000 + vdelay.usec / 1000; } } diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index e596cac..826265a 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -50,7 +50,7 @@ TCL_DECLARE_MUTEX(pipeMutex) * used in a pipeline. */ -typedef struct WinFile { +typedef struct { int type; /* One of the file types defined above. */ HANDLE handle; /* Open file handle. */ } WinFile; @@ -82,6 +82,12 @@ static ProcInfo *procList; #define PIPE_EXTRABYTE (1<<3) /* The reader thread has consumed one byte. */ /* + * TODO: It appears the whole EXTRABYTE machinery is in place to support + * outdated Win 95 systems. If this can be confirmed, much code can be + * deleted. + */ + +/* * This structure describes per-instance data for a pipe based channel. */ @@ -103,24 +109,17 @@ typedef struct PipeInfo { Tcl_ThreadId threadId; /* Thread to which events should be reported. * This value is used by the reader/writer * threads. */ + TclPipeThreadInfo *writeTI; /* Thread info of writer and reader, this */ + TclPipeThreadInfo *readTI; /* structure owned by corresponding 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 pipe. */ - HANDLE stopWriter; /* Manual-reset event used to alert the reader - * thread to fall-out and exit */ - HANDLE startReader; /* Auto-reset event used by the main thread to - * signal when the reader thread should - * attempt to read from the pipe. */ - HANDLE stopReader; /* Manual-reset event used to alert the reader - * thread to fall-out and 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 @@ -142,7 +141,7 @@ typedef struct PipeInfo { * synchronized with the readable object. */ } PipeInfo; -typedef struct ThreadSpecificData { +typedef struct { /* * The following pointer refers to the head of the list of pipes that are * being watched for file events. @@ -158,7 +157,7 @@ static Tcl_ThreadDataKey dataKey; * events are generated. */ -typedef struct PipeEvent { +typedef struct { Tcl_Event header; /* Information that is standard for all * events. */ PipeInfo *infoPtr; /* Pointer to pipe info structure. Note that @@ -192,7 +191,7 @@ static DWORD WINAPI PipeReaderThread(LPVOID arg); static void PipeSetupProc(ClientData clientData, int flags); static void PipeWatchProc(ClientData instanceData, int mask); static DWORD WINAPI PipeWriterThread(LPVOID arg); -static int TempFileName(WCHAR name[MAX_PATH]); +static int TempFileName(TCHAR name[MAX_PATH]); static int WaitForRead(PipeInfo *infoPtr, int blocking); static void PipeThreadActionProc(ClientData instanceData, int action); @@ -202,7 +201,7 @@ static void PipeThreadActionProc(ClientData instanceData, * I/O. */ -static Tcl_ChannelType pipeChannelType = { +static const Tcl_ChannelType pipeChannelType = { "pipe", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ TCL_CLOSE2PROC, /* Close proc. */ @@ -219,7 +218,7 @@ static Tcl_ChannelType pipeChannelType = { NULL, /* handler proc. */ NULL, /* wide seek proc */ PipeThreadActionProc, /* thread action proc */ - NULL, /* truncate */ + NULL /* truncate */ }; /* @@ -404,7 +403,7 @@ PipeCheckProc( if (needEvent) { infoPtr->flags |= PIPE_PENDING; - evPtr = (PipeEvent *) ckalloc(sizeof(PipeEvent)); + evPtr = ckalloc(sizeof(PipeEvent)); evPtr->header.proc = PipeEventProc; evPtr->infoPtr = infoPtr; Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); @@ -435,7 +434,7 @@ TclWinMakeFile( { WinFile *filePtr; - filePtr = (WinFile *) ckalloc(sizeof(WinFile)); + filePtr = ckalloc(sizeof(WinFile)); filePtr->type = WIN_FILE; filePtr->handle = handle; @@ -464,27 +463,18 @@ TclWinMakeFile( static int TempFileName( - WCHAR name[MAX_PATH]) /* Buffer in which name for temporary file + TCHAR name[MAX_PATH]) /* Buffer in which name for temporary file * gets stored. */ { - TCHAR *prefix; - - prefix = (tclWinProcs->useWide) ? (TCHAR *) L"TCL" : (TCHAR *) "TCL"; - if ((*tclWinProcs->getTempPathProc)(MAX_PATH, name) != 0) { - if ((*tclWinProcs->getTempFileNameProc)((TCHAR *) name, prefix, 0, - name) != 0) { + const TCHAR *prefix = TEXT("TCL"); + if (GetTempPath(MAX_PATH, name) != 0) { + if (GetTempFileName(name, prefix, 0, name) != 0) { return 1; } } - if (tclWinProcs->useWide) { - ((WCHAR *) name)[0] = '.'; - ((WCHAR *) name)[1] = '\0'; - } else { - ((char *) name)[0] = '.'; - ((char *) name)[1] = '\0'; - } - return (*tclWinProcs->getTempFileNameProc)((TCHAR *) name, prefix, 0, - name); + name[0] = '.'; + name[1] = '\0'; + return GetTempFileName(name, prefix, 0, name); } /* @@ -596,7 +586,7 @@ TclpOpenFile( flags = 0; if (!(mode & O_CREAT)) { - flags = (*tclWinProcs->getFileAttributesProc)(nativePath); + flags = GetFileAttributes(nativePath); if (flags == 0xFFFFFFFF) { flags = 0; } @@ -612,8 +602,8 @@ TclpOpenFile( * Now we get to create the file. */ - handle = (*tclWinProcs->createFileProc)(nativePath, accessMode, - shareMode, NULL, createMode, flags, NULL); + handle = CreateFile(nativePath, accessMode, shareMode, + NULL, createMode, flags, NULL); Tcl_DStringFree(&ds); if (handle == INVALID_HANDLE_VALUE) { @@ -660,7 +650,7 @@ TclFile TclpCreateTempFile( const char *contents) /* String to write into temp file, or NULL. */ { - WCHAR name[MAX_PATH]; + TCHAR name[MAX_PATH]; const char *native; Tcl_DString dstring; HANDLE handle; @@ -669,7 +659,7 @@ TclpCreateTempFile( return NULL; } - handle = (*tclWinProcs->createFileProc)((TCHAR *) name, + handle = CreateFile(name, GENERIC_READ | GENERIC_WRITE, 0, NULL, CREATE_ALWAYS, FILE_ATTRIBUTE_TEMPORARY|FILE_FLAG_DELETE_ON_CLOSE, NULL); if (handle == INVALID_HANDLE_VALUE) { @@ -731,7 +721,7 @@ TclpCreateTempFile( TclWinConvertError(GetLastError()); CloseHandle(handle); - (*tclWinProcs->deleteFileProc)((TCHAR *) name); + DeleteFile(name); return NULL; } @@ -754,13 +744,13 @@ TclpCreateTempFile( Tcl_Obj * TclpTempFileName(void) { - WCHAR fileName[MAX_PATH]; + TCHAR fileName[MAX_PATH]; if (TempFileName(fileName) == 0) { return NULL; } - return TclpNativeToNormalized((ClientData) fileName); + return TclpNativeToNormalized(fileName); } /* @@ -836,7 +826,7 @@ TclpCloseFile( if (filePtr->handle != NULL && CloseHandle(filePtr->handle) == FALSE) { TclWinConvertError(GetLastError()); - ckfree((char *) filePtr); + ckfree(filePtr); return -1; } } @@ -846,7 +836,7 @@ TclpCloseFile( Tcl_Panic("TclpCloseFile: unexpected file type"); } - ckfree((char *) filePtr); + ckfree(filePtr); return 0; } @@ -900,7 +890,7 @@ TclpGetPid( * * The complete Windows search path is searched to find the specified * executable. If an executable by the given name is not found, - * automatically tries appending ".com", ".exe", ".bat" and ".cmd" to the + * automatically tries appending standard extensions to the * executable name. * * Results: @@ -947,7 +937,7 @@ TclpCreateProcess( { int result, applType, createFlags; Tcl_DString cmdLine; /* Complete command line (TCHAR). */ - STARTUPINFOA startInfo; + STARTUPINFO startInfo; PROCESS_INFORMATION procInfo; SECURITY_ATTRIBUTES secAtts; HANDLE hProcess, h, inputHandle, outputHandle, errorHandle; @@ -1037,8 +1027,9 @@ TclpCreateProcess( } if (startInfo.hStdInput == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "couldn't duplicate input handle: ", - Tcl_PosixError(interp), (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't duplicate input handle: %s", + Tcl_PosixError(interp))); goto end; } @@ -1057,23 +1048,17 @@ TclpCreateProcess( * sink. */ - if ((TclWinGetPlatformId() == VER_PLATFORM_WIN32_WINDOWS) - && (applType == APPL_DOS)) { - if (CreatePipe(&h, &startInfo.hStdOutput, &secAtts, 0) != FALSE) { - CloseHandle(h); - } - } else { - startInfo.hStdOutput = CreateFileA("NUL:", GENERIC_WRITE, 0, - &secAtts, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL); - } + startInfo.hStdOutput = CreateFile(TEXT("NUL:"), GENERIC_WRITE, 0, + &secAtts, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL); } else { DuplicateHandle(hProcess, outputHandle, hProcess, &startInfo.hStdOutput, 0, TRUE, DUPLICATE_SAME_ACCESS); } if (startInfo.hStdOutput == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "couldn't duplicate output handle: ", - Tcl_PosixError(interp), (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't duplicate output handle: %s", + Tcl_PosixError(interp))); goto end; } @@ -1083,7 +1068,7 @@ TclpCreateProcess( * sink. */ - startInfo.hStdError = CreateFileA("NUL:", GENERIC_WRITE, 0, + startInfo.hStdError = CreateFile(TEXT("NUL:"), GENERIC_WRITE, 0, &secAtts, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); } else { DuplicateHandle(hProcess, errorHandle, hProcess, &startInfo.hStdError, @@ -1091,8 +1076,9 @@ TclpCreateProcess( } if (startInfo.hStdError == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "couldn't duplicate error handle: ", - Tcl_PosixError(interp), (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't duplicate error handle: %s", + Tcl_PosixError(interp))); goto end; } @@ -1124,7 +1110,7 @@ TclpCreateProcess( startInfo.wShowWindow = SW_HIDE; startInfo.dwFlags |= STARTF_USESHOWWINDOW; createFlags = CREATE_NEW_CONSOLE; - Tcl_DStringAppend(&cmdLine, "cmd.exe /c", -1); + TclDStringAppendLiteral(&cmdLine, "cmd.exe /c"); } else { createFlags = DETACHED_PROCESS; } @@ -1136,82 +1122,12 @@ TclpCreateProcess( } if (applType == APPL_DOS) { - /* - * Under Windows 95, 16-bit DOS applications do not work well with - * pipes: - * - * 1. EOF on a pipe between a detached 16-bit DOS application and - * another application is not seen at the other end of the pipe, - * so the listening process blocks forever on reads. This inablity - * to detect EOF happens when either a 16-bit app or the 32-bit - * app is the listener. - * - * 2. If a 16-bit DOS application (detached or not) blocks when - * writing to a pipe, it will never wake up again, and it - * eventually brings the whole system down around it. - * - * The 16-bit application is run as a normal process inside of a - * hidden helper console app, and this helper may be run as a - * detached process. If any of the stdio handles is a pipe, the - * helper application accumulates information into temp files and - * forwards it to or from the DOS application as appropriate. - * This means that DOS apps must receive EOF from a stdin pipe - * before they will actually begin, and must finish generating - * stdout or stderr before the data will be sent to the next stage - * of the pipe. - * - * The helper app should be located in the same directory as the - * tcl dll. - */ - Tcl_Obj *tclExePtr, *pipeDllPtr; - char *start, *end; - int i, fileExists; - Tcl_DString pipeDll; - - if (createFlags != 0) { - startInfo.wShowWindow = SW_HIDE; - startInfo.dwFlags |= STARTF_USESHOWWINDOW; - createFlags = CREATE_NEW_CONSOLE; - } - - Tcl_DStringInit(&pipeDll); - Tcl_DStringAppend(&pipeDll, TCL_PIPE_DLL, -1); - tclExePtr = TclGetObjNameOfExecutable(); - Tcl_IncrRefCount(tclExePtr); - start = Tcl_GetStringFromObj(tclExePtr, &i); - for (end = start + (i-1); end > start; end--) { - if (*end == '/') { - break; - } - } - if (*end != '/') { - Tcl_AppendResult(interp, "no / in executable path name \"", - start, "\"", (char *) NULL); - Tcl_DecrRefCount(tclExePtr); - Tcl_DStringFree(&pipeDll); - goto end; - } - i = (end - start) + 1; - pipeDllPtr = Tcl_NewStringObj(start, i); - Tcl_AppendToObj(pipeDllPtr, Tcl_DStringValue(&pipeDll), -1); - Tcl_IncrRefCount(pipeDllPtr); - if (Tcl_FSConvertToPathType(interp, pipeDllPtr) != TCL_OK) { - Tcl_Panic("Tcl_FSConvertToPathType failed"); - } - fileExists = (Tcl_FSAccess(pipeDllPtr, F_OK) == 0); - if (!fileExists) { - Tcl_AppendResult(interp, "Tcl pipe dll \"", - Tcl_DStringValue(&pipeDll), "\" not found", - (char *) NULL); - Tcl_DecrRefCount(tclExePtr); - Tcl_DecrRefCount(pipeDllPtr); - Tcl_DStringFree(&pipeDll); - goto end; - } - Tcl_DStringAppend(&cmdLine, Tcl_DStringValue(&pipeDll), -1); - Tcl_DecrRefCount(tclExePtr); - Tcl_DecrRefCount(pipeDllPtr); - Tcl_DStringFree(&pipeDll); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "DOS application process not supported on this platform", + -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "DOS_APP", + NULL); + goto end; } } @@ -1235,12 +1151,12 @@ TclpCreateProcess( BuildCommandLine(execPath, argc, argv, &cmdLine); - if ((*tclWinProcs->createProcessProc)(NULL, - (TCHAR *) Tcl_DStringValue(&cmdLine), NULL, NULL, TRUE, - (DWORD) createFlags, NULL, NULL, &startInfo, &procInfo) == 0) { + if (CreateProcess(NULL, (TCHAR *) Tcl_DStringValue(&cmdLine), + NULL, NULL, TRUE, (DWORD) createFlags, NULL, NULL, &startInfo, + &procInfo) == 0) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "couldn't execute \"", argv[0], - "\": ", Tcl_PosixError(interp), (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("couldn't execute \"%s\": %s", + argv[0], Tcl_PosixError(interp))); goto end; } @@ -1368,7 +1284,7 @@ ApplicationType( IMAGE_DOS_HEADER header; Tcl_DString nameBuf, ds; const TCHAR *nativeName; - WCHAR nativeFullPath[MAX_PATH]; + TCHAR nativeFullPath[MAX_PATH]; static const char extensions[][5] = {"", ".com", ".exe", ".bat", ".cmd"}; /* @@ -1394,8 +1310,8 @@ ApplicationType( Tcl_DStringAppend(&nameBuf, extensions[i], -1); nativeName = Tcl_WinUtfToTChar(Tcl_DStringValue(&nameBuf), Tcl_DStringLength(&nameBuf), &ds); - found = (*tclWinProcs->searchPathProc)(NULL, nativeName, NULL, - MAX_PATH, nativeFullPath, &rest); + found = SearchPath(NULL, nativeName, NULL, MAX_PATH, + nativeFullPath, &rest); Tcl_DStringFree(&ds); if (found == 0) { continue; @@ -1406,21 +1322,21 @@ ApplicationType( * known type. */ - attr = (*tclWinProcs->getFileAttributesProc)((TCHAR *) nativeFullPath); + attr = GetFileAttributes(nativeFullPath); if ((attr == 0xffffffff) || (attr & FILE_ATTRIBUTE_DIRECTORY)) { continue; } - strcpy(fullName, Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds)); + strcpy(fullName, Tcl_WinTCharToUtf(nativeFullPath, -1, &ds)); Tcl_DStringFree(&ds); ext = strrchr(fullName, '.'); if ((ext != NULL) && - (strcasecmp(ext, ".cmd") == 0 || strcasecmp(ext, ".bat") == 0)) { + (strcasecmp(ext, ".cmd") == 0 || strcasecmp(ext, ".bat") == 0)) { applType = APPL_DOS; break; } - hFile = (*tclWinProcs->createFileProc)((TCHAR *) nativeFullPath, + hFile = CreateFile(nativeFullPath, GENERIC_READ, FILE_SHARE_READ, NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); if (hFile == INVALID_HANDLE_VALUE) { @@ -1487,8 +1403,8 @@ ApplicationType( if (applType == APPL_NONE) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "couldn't execute \"", originalName, - "\": ", Tcl_PosixError(interp), (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("couldn't execute \"%s\": %s", + originalName, Tcl_PosixError(interp))); return APPL_NONE; } @@ -1500,9 +1416,8 @@ ApplicationType( * application name from the arguments. */ - (*tclWinProcs->getShortPathNameProc)((TCHAR *) nativeFullPath, - nativeFullPath, MAX_PATH); - strcpy(fullName, Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds)); + GetShortPathName(nativeFullPath, nativeFullPath, MAX_PATH); + strcpy(fullName, Tcl_WinTCharToUtf(nativeFullPath, -1, &ds)); Tcl_DStringFree(&ds); } return applType; @@ -1558,7 +1473,7 @@ QuoteCmdLineBackslash( Tcl_DStringAppend(dsPtr, start, (int) (bspos - start)); } while (bspos++ < current) { /* each backslash twice */ - Tcl_DStringAppend(dsPtr, "\\\\", 2); + TclDStringAppendLiteral(dsPtr, "\\\\"); } } } @@ -1580,13 +1495,13 @@ QuoteCmdLinePart( QuoteCmdLineBackslash(dsPtr, start, *bspos, NULL); start = *bspos; } - /* - * escape all special chars enclosed in quotes like `"..."`, note that here we + /* + * escape all special chars enclosed in quotes like `"..."`, note that here we * don't must escape `\` (with `\`), because it's outside of the main quotes, - * so `\` remains `\`, but important - not at end of part, because results as + * so `\` remains `\`, but important - not at end of part, because results as * before the quote, so `%\%\` should be escaped as `"%\%"\\`). */ - Tcl_DStringAppend(dsPtr, "\"", 1); /* opening escape quote-char */ + TclDStringAppendLiteral(dsPtr, "\""); /* opening escape quote-char */ do { *bspos = NULL; special++; @@ -1603,7 +1518,7 @@ QuoteCmdLinePart( /* unescaped rest before first backslash (rather belongs to the main block) */ QuoteCmdLineBackslash(dsPtr, start, *bspos, NULL); } - Tcl_DStringAppend(dsPtr, "\"", 1); /* closing escape quote-char */ + TclDStringAppendLiteral(dsPtr, "\""); /* closing escape quote-char */ return special; } @@ -1638,9 +1553,9 @@ BuildCommandLine( * Prime the path. Add a space separator if we were primed with something. */ - Tcl_DStringAppend(&ds, Tcl_DStringValue(linePtr), -1); + TclDStringAppendDString(&ds, linePtr); if (Tcl_DStringLength(linePtr) > 0) { - Tcl_DStringAppend(&ds, " ", 1); + TclDStringAppendLiteral(&ds, " "); } for (i = 0; i < argc; i++) { @@ -1648,7 +1563,7 @@ BuildCommandLine( arg = executable; } else { arg = argv[i]; - Tcl_DStringAppend(&ds, " ", 1); + TclDStringAppendLiteral(&ds, " "); } quote &= ~(CL_ESCAPE|CL_QUOTE); /* reset escape flags */ @@ -1694,7 +1609,7 @@ BuildCommandLine( } if (quote & CL_QUOTE) { /* start of argument (main opening quote-char) */ - Tcl_DStringAppend(&ds, "\"", 1); + TclDStringAppendLiteral(&ds, "\""); } if (!(quote & CL_ESCAPE)) { /* nothing to escape */ @@ -1715,7 +1630,7 @@ BuildCommandLine( QuoteCmdLineBackslash(&ds, start, special, bspos); bspos = NULL; /* escape using backslash */ - Tcl_DStringAppend(&ds, "\\\"", 2); + TclDStringAppendLiteral(&ds, "\\\""); start = ++special; continue; } @@ -1738,12 +1653,12 @@ BuildCommandLine( special++; } /* rest of argument (and escape backslashes before closing main quote) */ - QuoteCmdLineBackslash(&ds, start, special, + QuoteCmdLineBackslash(&ds, start, special, (quote & CL_QUOTE) ? bspos : NULL); } if (quote & CL_QUOTE) { /* end of argument (main closing quote-char) */ - Tcl_DStringAppend(&ds, "\"", 1); + TclDStringAppendLiteral(&ds, "\""); } } Tcl_DStringFree(linePtr); @@ -1778,8 +1693,7 @@ TclpCreateCommandChannel( Tcl_Pid *pidPtr) /* An array of process identifiers. */ { char channelName[16 + TCL_INTEGER_SPACE]; - DWORD id; - PipeInfo *infoPtr = (PipeInfo *) ckalloc((unsigned) sizeof(PipeInfo)); + PipeInfo *infoPtr = ckalloc(sizeof(PipeInfo)); PipeInit(); @@ -1794,7 +1708,7 @@ TclpCreateCommandChannel( infoPtr->writeBuf = 0; infoPtr->writeBufLen = 0; infoPtr->writeError = 0; - infoPtr->channel = (Tcl_Channel) NULL; + infoPtr->channel = NULL; infoPtr->validMask = 0; @@ -1806,13 +1720,13 @@ TclpCreateCommandChannel( */ infoPtr->readable = CreateEvent(NULL, TRUE, TRUE, NULL); - infoPtr->startReader = CreateEvent(NULL, FALSE, FALSE, NULL); - infoPtr->stopReader = CreateEvent(NULL, TRUE, FALSE, NULL); infoPtr->readThread = CreateThread(NULL, 256, PipeReaderThread, - infoPtr, 0, &id); + TclPipeThreadCreateTI(&infoPtr->readTI, infoPtr, infoPtr->readable), + 0, NULL); SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST); infoPtr->validMask |= TCL_READABLE; } else { + infoPtr->readTI = NULL; infoPtr->readThread = 0; } if (writeFile != NULL) { @@ -1821,12 +1735,14 @@ TclpCreateCommandChannel( */ infoPtr->writable = CreateEvent(NULL, TRUE, TRUE, NULL); - infoPtr->startWriter = CreateEvent(NULL, FALSE, FALSE, NULL); - infoPtr->stopWriter = CreateEvent(NULL, TRUE, FALSE, NULL); infoPtr->writeThread = CreateThread(NULL, 256, PipeWriterThread, - infoPtr, 0, &id); + TclPipeThreadCreateTI(&infoPtr->writeTI, infoPtr, infoPtr->writable), + 0, NULL); SetThreadPriority(infoPtr->writeThread, THREAD_PRIORITY_HIGHEST); infoPtr->validMask |= TCL_WRITABLE; + } else { + infoPtr->writeTI = NULL; + infoPtr->writeThread = 0; } /* @@ -1836,9 +1752,9 @@ TclpCreateCommandChannel( * unique, in case channels share handles (stdin/stdout). */ - sprintf(channelName, "file%" TCL_I_MODIFIER "x", (size_t)infoPtr); + sprintf(channelName, "file%" TCL_I_MODIFIER "x", (size_t) infoPtr); infoPtr->channel = Tcl_CreateChannel(&pipeChannelType, channelName, - (ClientData) infoPtr, infoPtr->validMask); + infoPtr, infoPtr->validMask); /* * Pipes have AUTO translation mode on Windows and ^Z eof char, which @@ -1846,16 +1762,58 @@ TclpCreateCommandChannel( * Windows programs that expect a ^Z at EOF. */ - Tcl_SetChannelOption((Tcl_Interp *) NULL, infoPtr->channel, - "-translation", "auto"); - Tcl_SetChannelOption((Tcl_Interp *) NULL, infoPtr->channel, - "-eofchar", "\032 {}"); + Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto"); + Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}"); return infoPtr->channel; } /* *---------------------------------------------------------------------- * + * Tcl_CreatePipe -- + * + * System dependent interface to create a pipe for the [chan pipe] + * command. Stolen from TclX. + * + * Results: + * TCL_OK or TCL_ERROR. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_CreatePipe( + Tcl_Interp *interp, /* Errors returned in result.*/ + Tcl_Channel *rchan, /* Where to return the read side. */ + Tcl_Channel *wchan, /* Where to return the write side. */ + int flags) /* Reserved for future use. */ +{ + HANDLE readHandle, writeHandle; + SECURITY_ATTRIBUTES sec; + + sec.nLength = sizeof(SECURITY_ATTRIBUTES); + sec.lpSecurityDescriptor = NULL; + sec.bInheritHandle = FALSE; + + if (!CreatePipe(&readHandle, &writeHandle, &sec, 0)) { + TclWinConvertError(GetLastError()); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "pipe creation failed: %s", Tcl_PosixError(interp))); + return TCL_ERROR; + } + + *rchan = Tcl_MakeFileChannel((ClientData) readHandle, TCL_READABLE); + Tcl_RegisterChannel(interp, *rchan); + + *wchan = Tcl_MakeFileChannel((ClientData) writeHandle, TCL_WRITABLE); + Tcl_RegisterChannel(interp, *wchan); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TclGetAndDetachPids -- * * Stores a list of the command PIDs for a command channel in the @@ -1877,8 +1835,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. @@ -1889,14 +1847,17 @@ TclGetAndDetachPids( return; } - pipePtr = (PipeInfo *) Tcl_GetChannelInstanceData(chan); + pipePtr = Tcl_GetChannelInstanceData(chan); + TclNewObj(pidsObj); for (i = 0; i < pipePtr->numPids; i++) { - wsprintfA(buf, "%lu", TclpGetPid(pipePtr->pidPtr[i])); - Tcl_AppendElement(interp, buf); - Tcl_DetachPids(1, &(pipePtr->pidPtr[i])); + Tcl_ListObjAppendElement(NULL, pidsObj, + Tcl_NewWideIntObj((unsigned) + TclpGetPid(pipePtr->pidPtr[i]))); + Tcl_DetachPids(1, &pipePtr->pidPtr[i]); } + Tcl_SetObjResult(interp, pidsObj); if (pipePtr->numPids > 0) { - ckfree((char *) pipePtr->pidPtr); + ckfree(pipePtr->pidPtr); pipePtr->numPids = 0; } } @@ -1967,12 +1928,12 @@ PipeClose2Proc( int errorCode, result; PipeInfo *infoPtr, **nextPtrPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - DWORD exitCode; + int inExit = (TclInExit() || TclInThreadExit()); errorCode = 0; result = 0; - if ((!flags || flags == TCL_CLOSE_READ) && (pipePtr->readFile != NULL)) { + if ((!flags || flags & TCL_CLOSE_READ) && (pipePtr->readFile != NULL)) { /* * Clean up the background thread if necessary. Note that this must be * done before we can close the file, since the thread may be blocking @@ -1980,55 +1941,10 @@ PipeClose2Proc( */ if (pipePtr->readThread) { - /* - * The thread may already have closed on its own. Check its exit - * code. - */ - - GetExitCodeThread(pipePtr->readThread, &exitCode); - - if (exitCode == STILL_ACTIVE) { - /* - * Set the stop event so that if the reader thread is blocked - * in PipeReaderThread on WaitForMultipleEvents, it will exit - * cleanly. - */ - - SetEvent(pipePtr->stopReader); - - /* - * Wait at most 20 milliseconds for the reader thread to - * close. - */ - - if (WaitForSingleObject(pipePtr->readThread, - 20) == WAIT_TIMEOUT) { - /* - * The thread must be blocked waiting for the pipe to - * become readable in ReadFile(). There isn't a clean way - * to exit the thread from this condition. We should - * terminate the child process instead to get the reader - * thread to fall out of ReadFile with a FALSE. (below) is - * not the correct way to do this, but will stay here - * until a better solution is found. - * - * 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(&pipeMutex); - - /* BUG: this leaks memory */ - TerminateThread(pipePtr->readThread, 0); - Tcl_MutexUnlock(&pipeMutex); - } - } + TclPipeThreadStop(&pipePtr->readTI, pipePtr->readThread); CloseHandle(pipePtr->readThread); CloseHandle(pipePtr->readable); - CloseHandle(pipePtr->startReader); - CloseHandle(pipePtr->stopReader); pipePtr->readThread = NULL; } if (TclpCloseFile(pipePtr->readFile) != 0) { @@ -2037,66 +1953,34 @@ PipeClose2Proc( pipePtr->validMask &= ~TCL_READABLE; pipePtr->readFile = NULL; } - if ((!flags || flags & TCL_CLOSE_WRITE) - && (pipePtr->writeFile != NULL)) { + if ((!flags || flags & TCL_CLOSE_WRITE) && (pipePtr->writeFile != NULL)) { if (pipePtr->writeThread) { - /* - * Wait for the writer thread to finish the current buffer, then - * terminate the thread and close the handles. If the channel is - * nonblocking, there should be no pending write operations. - */ - - WaitForSingleObject(pipePtr->writable, INFINITE); /* - * The thread may already have closed on it's own. Check its exit - * code. + * Wait for the writer thread to finish the current buffer, then + * terminate the thread and close the handles. If the channel is + * nonblocking or may block during exit, bail out since the worker + * thread is not interruptible and we want TIP#398-fast-exit. */ + if ((pipePtr->flags & PIPE_ASYNC) && inExit) { - GetExitCodeThread(pipePtr->writeThread, &exitCode); - - if (exitCode == STILL_ACTIVE) { - /* - * Set the stop event so that if the reader thread is blocked - * in PipeReaderThread on WaitForMultipleEvents, it will exit - * cleanly. - */ - - SetEvent(pipePtr->stopWriter); + /* give it a chance to leave honorably */ + TclPipeThreadStopSignal(&pipePtr->writeTI, pipePtr->writable); - /* - * Wait at most 20 milliseconds for the reader thread to - * close. - */ + if (WaitForSingleObject(pipePtr->writable, 20) == WAIT_TIMEOUT) { + return EWOULDBLOCK; + } - if (WaitForSingleObject(pipePtr->writeThread, - 20) == WAIT_TIMEOUT) { - /* - * The thread must be blocked waiting for the pipe to - * consume input in WriteFile(). There isn't a clean way - * to exit the thread from this condition. We should - * terminate the child process instead to get the writer - * thread to fall out of WriteFile with a FALSE. (below) - * is not the correct way to do this, but will stay here - * until a better solution is found. - * - * Note that we need to guard against terminating the - * thread while it is in the middle of Tcl_ThreadAlert - * because it won't be able to release the notifier lock. - */ + } else { - Tcl_MutexLock(&pipeMutex); + WaitForSingleObject(pipePtr->writable, inExit ? 5000 : INFINITE); - /* BUG: this leaks memory */ - TerminateThread(pipePtr->writeThread, 0); - Tcl_MutexUnlock(&pipeMutex); - } } - CloseHandle(pipePtr->writeThread); + TclPipeThreadStop(&pipePtr->writeTI, pipePtr->writeThread); + CloseHandle(pipePtr->writable); - CloseHandle(pipePtr->startWriter); - CloseHandle(pipePtr->stopWriter); + CloseHandle(pipePtr->writeThread); pipePtr->writeThread = NULL; } if (TclpCloseFile(pipePtr->writeFile) != 0) { @@ -2131,7 +2015,7 @@ PipeClose2Proc( } } - if ((pipePtr->flags & PIPE_ASYNC) || TclInExit()) { + if ((pipePtr->flags & PIPE_ASYNC) || inExit) { /* * If the channel is non-blocking or Tcl is being cleaned up, just * detach the children PIDs, reap them (important if we are in a @@ -2156,12 +2040,11 @@ PipeClose2Proc( */ if (pipePtr->errorFile) { - WinFile *filePtr; + WinFile *filePtr = (WinFile *) pipePtr->errorFile; - filePtr = (WinFile*)pipePtr->errorFile; errChan = Tcl_MakeFileChannel((ClientData) filePtr->handle, TCL_READABLE); - ckfree((char *) filePtr); + ckfree(filePtr); } else { errChan = NULL; } @@ -2171,14 +2054,14 @@ PipeClose2Proc( } if (pipePtr->numPids > 0) { - ckfree((char *) pipePtr->pidPtr); + ckfree(pipePtr->pidPtr); } if (pipePtr->writeBuf != NULL) { ckfree(pipePtr->writeBuf); } - ckfree((char*) pipePtr); + ckfree(pipePtr); if (errorCode == 0) { return result; @@ -2310,14 +2193,17 @@ PipeOutputProc( DWORD bytesWritten, timeout; *errorCode = 0; - timeout = (infoPtr->flags & PIPE_ASYNC) ? 0 : INFINITE; + + /* avoid blocking if pipe-thread exited */ + timeout = ((infoPtr->flags & PIPE_ASYNC) || !TclPipeThreadIsAlive(&infoPtr->writeTI) + || TclInExit() || TclInThreadExit()) ? 0 : INFINITE; if (WaitForSingleObject(infoPtr->writable, timeout) == WAIT_TIMEOUT) { /* * The writer thread is blocked waiting for a write to complete and * the channel is in non-blocking mode. */ - errno = EAGAIN; + errno = EWOULDBLOCK; goto error; } @@ -2346,12 +2232,12 @@ PipeOutputProc( ckfree(infoPtr->writeBuf); } infoPtr->writeBufLen = toWrite; - infoPtr->writeBuf = ckalloc((unsigned int) toWrite); + infoPtr->writeBuf = ckalloc(toWrite); } memcpy(infoPtr->writeBuf, buf, (size_t) toWrite); infoPtr->toWrite = toWrite; ResetEvent(infoPtr->writable); - SetEvent(infoPtr->startWriter); + TclPipeThreadSignal(&infoPtr->writeTI); bytesWritten = toWrite; } else { /* @@ -2725,7 +2611,7 @@ Tcl_WaitPid( */ CloseHandle(infoPtr->hProcess); - ckfree((char*)infoPtr); + ckfree(infoPtr); return result; } @@ -2751,9 +2637,9 @@ Tcl_WaitPid( void TclWinAddProcess( void *hProcess, /* Handle to process */ - unsigned long id) /* Global process identifier */ + unsigned long id) /* Global process identifier */ { - ProcInfo *procPtr = (ProcInfo *) ckalloc(sizeof(ProcInfo)); + ProcInfo *procPtr = ckalloc(sizeof(ProcInfo)); PipeInit(); @@ -2795,17 +2681,15 @@ Tcl_PidObjCmd( PipeInfo *pipePtr; int i; Tcl_Obj *resultPtr; - char buf[TCL_INTEGER_SPACE]; if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "?channelId?"); return TCL_ERROR; } if (objc == 1) { - wsprintfA(buf, "%lu", (unsigned long) getpid()); - Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, -1)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj((unsigned) getpid())); } else { - chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), + chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; @@ -2818,9 +2702,9 @@ Tcl_PidObjCmd( pipePtr = (PipeInfo *) Tcl_GetChannelInstanceData(chan); resultPtr = Tcl_NewObj(); for (i = 0; i < pipePtr->numPids; i++) { - wsprintfA(buf, "%lu", TclpGetPid(pipePtr->pidPtr[i])); Tcl_ListObjAppendElement(/*interp*/ NULL, resultPtr, - Tcl_NewStringObj(buf, -1)); + Tcl_NewWideIntObj((unsigned) + TclpGetPid(pipePtr->pidPtr[i]))); } Tcl_SetObjResult(interp, resultPtr); } @@ -2863,14 +2747,16 @@ WaitForRead( * Synchronize with the reader thread. */ - timeout = blocking ? INFINITE : 0; + /* avoid blocking if pipe-thread exited */ + timeout = (!blocking || !TclPipeThreadIsAlive(&infoPtr->readTI) + || TclInExit() || TclInThreadExit()) ? 0 : INFINITE; if (WaitForSingleObject(infoPtr->readable, timeout) == WAIT_TIMEOUT) { /* * The reader thread is blocked waiting for data and the channel * is in non-blocking mode. */ - errno = EAGAIN; + errno = EWOULDBLOCK; return -1; } @@ -2937,7 +2823,7 @@ WaitForRead( */ ResetEvent(infoPtr->readable); - SetEvent(infoPtr->startReader); + TclPipeThreadSignal(&infoPtr->readTI); } } @@ -2965,33 +2851,27 @@ static DWORD WINAPI PipeReaderThread( LPVOID arg) { - PipeInfo *infoPtr = (PipeInfo *)arg; - HANDLE *handle = ((WinFile *) infoPtr->readFile)->handle; + TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *)arg; + PipeInfo *infoPtr = NULL; /* access info only after success init/wait */ + HANDLE handle = NULL; DWORD count, err; int done = 0; - HANDLE wEvents[2]; - DWORD waitResult; - - wEvents[0] = infoPtr->stopReader; - wEvents[1] = infoPtr->startReader; while (!done) { /* * Wait for the main thread to signal before attempting to wait on the * pipe becoming readable. */ - - waitResult = WaitForMultipleObjects(2, wEvents, FALSE, INFINITE); - - if (waitResult != (WAIT_OBJECT_0 + 1)) { - /* - * The start event was not signaled. It might be the stop event or - * an error, so exit. - */ - + if (!TclPipeThreadWaitForSignal(&pipeTI)) { + /* exit */ break; } + if (!infoPtr) { + infoPtr = (PipeInfo *)pipeTI->clientData; + handle = ((WinFile *) infoPtr->readFile)->handle; + } + /* * Try waiting for 0 bytes. This will block until some data is * available on NT, but will return immediately on Win 95. So, if no @@ -3011,7 +2891,7 @@ PipeReaderThread( infoPtr->readFlags |= PIPE_EOF; done = 1; } else if (err == ERROR_INVALID_HANDLE) { - break; + done = 1; } } else if (count == 0) { if (ReadFile(handle, &(infoPtr->extraByte), 1, &count, NULL) @@ -3033,12 +2913,11 @@ PipeReaderThread( infoPtr->readFlags |= PIPE_EOF; done = 1; } else if (err == ERROR_INVALID_HANDLE) { - break; + done = 1; } } } - /* * Signal the main thread by signalling the readable event and then * waking up the notifier thread. @@ -3064,6 +2943,12 @@ PipeReaderThread( Tcl_MutexUnlock(&pipeMutex); } + /* + * If state of thread was set to stop, we can sane free info structure, + * otherwise it is shared with main thread, so main thread will own it + */ + TclPipeThreadExit(&pipeTI); + return 0; } @@ -3088,33 +2973,27 @@ static DWORD WINAPI PipeWriterThread( LPVOID arg) { - PipeInfo *infoPtr = (PipeInfo *)arg; - HANDLE *handle = ((WinFile *) infoPtr->writeFile)->handle; + TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *)arg; + PipeInfo *infoPtr = NULL; /* access info only after success init/wait */ + HANDLE handle = NULL; DWORD count, toWrite; char *buf; int done = 0; - HANDLE wEvents[2]; - DWORD waitResult; - - wEvents[0] = infoPtr->stopWriter; - wEvents[1] = infoPtr->startWriter; while (!done) { /* * Wait for the main thread to signal before attempting to write. */ - - waitResult = WaitForMultipleObjects(2, wEvents, FALSE, INFINITE); - - if (waitResult != (WAIT_OBJECT_0 + 1)) { - /* - * The start event was not signaled. It might be the stop event or - * an error, so exit. - */ - + if (!TclPipeThreadWaitForSignal(&pipeTI)) { + /* exit */ break; } + if (!infoPtr) { + infoPtr = (PipeInfo *)pipeTI->clientData; + handle = ((WinFile *) infoPtr->writeFile)->handle; + } + buf = infoPtr->writeBuf; toWrite = infoPtr->toWrite; @@ -3158,6 +3037,12 @@ PipeWriterThread( Tcl_MutexUnlock(&pipeMutex); } + /* + * If state of thread was set to stop, we can sane free info structure, + * otherwise it is shared with main thread, so main thread will own it. + */ + TclPipeThreadExit(&pipeTI); + return 0; } @@ -3212,6 +3097,489 @@ 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; +} + +/* + *---------------------------------------------------------------------- + * + * TclPipeThreadCreateTI -- + * + * Creates a thread info structure, can be owned by worker. + * + * Results: + * Pointer to created TI structure. + * + *---------------------------------------------------------------------- + */ + +TclPipeThreadInfo * +TclPipeThreadCreateTI( + TclPipeThreadInfo **pipeTIPtr, + ClientData clientData, + HANDLE wakeEvent) +{ + TclPipeThreadInfo *pipeTI; +#ifndef _PTI_USE_CKALLOC + pipeTI = malloc(sizeof(TclPipeThreadInfo)); +#else + pipeTI = ckalloc(sizeof(TclPipeThreadInfo)); +#endif + pipeTI->evControl = CreateEvent(NULL, FALSE, FALSE, NULL); + pipeTI->state = PTI_STATE_IDLE; + pipeTI->clientData = clientData; + pipeTI->evWakeUp = wakeEvent; + return (*pipeTIPtr = pipeTI); +} + +/* + *---------------------------------------------------------------------- + * + * TclPipeThreadWaitForSignal -- + * + * Wait for work/stop signals inside pipe worker. + * + * Results: + * 1 if signaled to work, 0 if signaled to stop. + * + * Side effects: + * If this function returns 0, TI-structure pointer given via pipeTIPtr + * may be NULL, so not accessible (can be owned by main thread). + * + *---------------------------------------------------------------------- + */ + +int +TclPipeThreadWaitForSignal( + TclPipeThreadInfo **pipeTIPtr) +{ + TclPipeThreadInfo *pipeTI = *pipeTIPtr; + LONG state; + DWORD waitResult; + HANDLE wakeEvent; + + if (!pipeTI) { + return 0; + } + + wakeEvent = pipeTI->evWakeUp; + /* + * Wait for the main thread to signal before attempting to do the work. + */ + + /* reset work state of thread (idle/waiting) */ + if ((state = InterlockedCompareExchange(&pipeTI->state, + PTI_STATE_IDLE, PTI_STATE_WORK)) & (PTI_STATE_STOP|PTI_STATE_END)) { + /* end of work, check the owner of structure */ + goto end; + } + /* entering wait */ + waitResult = WaitForSingleObject(pipeTI->evControl, INFINITE); + + if (waitResult != WAIT_OBJECT_0) { + + /* + * The control event was not signaled, so end of work (unexpected + * behaviour, main thread can be dead?). + */ + goto end; + } + + /* try to set work state of thread */ + if ((state = InterlockedCompareExchange(&pipeTI->state, + PTI_STATE_WORK, PTI_STATE_IDLE)) & (PTI_STATE_STOP|PTI_STATE_END)) { + /* end of work */ + goto end; + } + + /* signaled to work */ + return 1; + +end: + /* end of work, check the owner of the TI structure */ + if (state != PTI_STATE_STOP) { + *pipeTIPtr = NULL; + } else { + pipeTI->evWakeUp = NULL; + } + if (wakeEvent) { + SetEvent(wakeEvent); + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclPipeThreadStopSignal -- + * + * Send stop signal to the pipe worker (without waiting). + * + * After calling of this function, TI-structure pointer given via pipeTIPtr + * may be NULL. + * + * Results: + * 1 if signaled (or pipe-thread is down), 0 if pipe thread still working. + * + *---------------------------------------------------------------------- + */ + +int +TclPipeThreadStopSignal( + TclPipeThreadInfo **pipeTIPtr, HANDLE wakeEvent) +{ + TclPipeThreadInfo *pipeTI = *pipeTIPtr; + HANDLE evControl; + int state; + + if (!pipeTI) { + return 1; + } + evControl = pipeTI->evControl; + pipeTI->evWakeUp = wakeEvent; + switch ( + (state = InterlockedCompareExchange(&pipeTI->state, + PTI_STATE_STOP, PTI_STATE_IDLE)) + ) { + + case PTI_STATE_IDLE: + + /* Thread was idle/waiting, notify it goes teardown */ + SetEvent(evControl); + + *pipeTIPtr = NULL; + + case PTI_STATE_DOWN: + + return 1; + + default: + /* + * Thread works currently, we should try to end it, own the TI structure + * (because of possible sharing the joint structures with thread) + */ + InterlockedExchange(&pipeTI->state, PTI_STATE_END); + break; + } + + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclPipeThreadStop -- + * + * Send stop signal to the pipe worker and wait for thread completion. + * + * May be combined with TclPipeThreadStopSignal. + * + * After calling of this function, TI-structure pointer given via pipeTIPtr + * is not accessible (owned by pipe worker or released here). + * + * Results: + * None. + * + * Side effects: + * Can terminate pipe worker (and / or stop its synchronous operations). + * + *---------------------------------------------------------------------- + */ + +void +TclPipeThreadStop( + TclPipeThreadInfo **pipeTIPtr, + HANDLE hThread) +{ + TclPipeThreadInfo *pipeTI = *pipeTIPtr; + HANDLE evControl; + int state; + + if (!pipeTI) { + return; + } + pipeTI = *pipeTIPtr; + evControl = pipeTI->evControl; + pipeTI->evWakeUp = NULL; + /* + * Try to sane stop the pipe worker, corresponding its current state + */ + switch ( + (state = InterlockedCompareExchange(&pipeTI->state, + PTI_STATE_STOP, PTI_STATE_IDLE)) + ) { + + case PTI_STATE_IDLE: + + /* Thread was idle/waiting, notify it goes teardown */ + SetEvent(evControl); + + /* we don't need to wait for it at all, thread frees himself (owns the TI structure) */ + pipeTI = NULL; + break; + + case PTI_STATE_STOP: + /* already stopped, thread frees himself (owns the TI structure) */ + pipeTI = NULL; + break; + case PTI_STATE_DOWN: + /* Thread already down (?), do nothing */ + + /* we don't need to wait for it, but we should free pipeTI */ + hThread = NULL; + break; + + /* case PTI_STATE_WORK: */ + default: + /* + * Thread works currently, we should try to end it, own the TI structure + * (because of possible sharing the joint structures with thread) + */ + if ((state = InterlockedCompareExchange(&pipeTI->state, + PTI_STATE_END, PTI_STATE_WORK)) == PTI_STATE_DOWN + ) { + /* we don't need to wait for it, but we should free pipeTI */ + hThread = NULL; + }; + break; + } + + if (pipeTI && hThread) { + DWORD exitCode; + + /* + * The thread may already have closed on its own. Check its exit + * code. + */ + + GetExitCodeThread(hThread, &exitCode); + + if (exitCode == STILL_ACTIVE) { + + int inExit = (TclInExit() || TclInThreadExit()); + /* + * Set the stop event so that if the pipe thread is blocked + * somewhere, it may hereafter sane exit cleanly. + */ + + SetEvent(evControl); + + /* + * Cancel all sync-IO of this thread (may be blocked there). + */ + if (tclWinProcs.cancelSynchronousIo) { + tclWinProcs.cancelSynchronousIo(hThread); + } + + /* + * Wait at most 20 milliseconds for the reader thread to + * close (regarding TIP#398-fast-exit). + */ + + /* if we want TIP#398-fast-exit. */ + if (WaitForSingleObject(hThread, inExit ? 0 : 20) == WAIT_TIMEOUT) { + + /* + * The thread must be blocked waiting for the pipe to + * become readable in ReadFile(). There isn't a clean way + * to exit the thread from this condition. We should + * terminate the child process instead to get the reader + * thread to fall out of ReadFile with a FALSE. (below) is + * not the correct way to do this, but will stay here + * until a better solution is found. + * + * Note that we need to guard against terminating the + * thread while it is in the middle of Tcl_ThreadAlert + * because it won't be able to release the notifier lock. + * + * Also note that terminating threads during their initialization or teardown phase + * may result in ntdll.dll's LoaderLock to remain locked indefinitely. + * This causes ntdll.dll's LdrpInitializeThread() to deadlock trying to acquire LoaderLock. + * LdrpInitializeThread() is executed within new threads to perform + * initialization and to execute DllMain() of all loaded dlls. + * As a result, all new threads are deadlocked in their initialization phase and never execute, + * even though CreateThread() reports successful thread creation. + * This results in a very weird process-wide behavior, which is extremely hard to debug. + * + * THREADS SHOULD NEVER BE TERMINATED. Period. + * + * But for now, check if thread is exiting, and if so, let it die peacefully. + * + * Also don't terminate if in exit (otherwise deadlocked in ntdll.dll's). + */ + + if ( pipeTI->state != PTI_STATE_DOWN + && WaitForSingleObject(hThread, + inExit ? 50 : 5000) != WAIT_OBJECT_0 + ) { + /* BUG: this leaks memory */ + if (inExit || !TerminateThread(hThread, 0)) { + /* in exit or terminate fails, just give thread a chance to exit */ + if (InterlockedExchange(&pipeTI->state, + PTI_STATE_STOP) != PTI_STATE_DOWN) { + pipeTI = NULL; + } + }; + } + } + } + } + + *pipeTIPtr = NULL; + if (pipeTI) { + if (pipeTI->evWakeUp) { + SetEvent(pipeTI->evWakeUp); + } + CloseHandle(pipeTI->evControl); + #ifndef _PTI_USE_CKALLOC + free(pipeTI); + #else + ckfree(pipeTI); + #endif + } +} + +/* + *---------------------------------------------------------------------- + * + * TclPipeThreadExit -- + * + * Clean-up for the pipe thread (removes owned TI-structure in worker). + * + * Should be executed on worker exit, to inform the main thread or + * free TI-structure (if owned). + * + * After calling of this function, TI-structure pointer given via pipeTIPtr + * is not accessible (owned by main thread or released here). + * + * Results: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclPipeThreadExit( + TclPipeThreadInfo **pipeTIPtr) +{ + LONG state; + TclPipeThreadInfo *pipeTI = *pipeTIPtr; + /* + * If state of thread was set to stop (exactly), we can sane free its info + * structure, otherwise it is shared with main thread, so main thread will + * own it. + */ + if (!pipeTI) { + return; + } + *pipeTIPtr = NULL; + if ((state = InterlockedExchange(&pipeTI->state, + PTI_STATE_DOWN)) == PTI_STATE_STOP) { + CloseHandle(pipeTI->evControl); + if (pipeTI->evWakeUp) { + SetEvent(pipeTI->evWakeUp); + } + #ifndef _PTI_USE_CKALLOC + free(pipeTI); + #else + ckfree(pipeTI); + /* be sure all subsystems used are finalized */ + Tcl_FinalizeThread(); + #endif + } +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/win/tclWinPort.h b/win/tclWinPort.h index c30d1bd..29b1447 100644 --- a/win/tclWinPort.h +++ b/win/tclWinPort.h @@ -14,11 +14,24 @@ #ifndef _TCLWINPORT #define _TCLWINPORT -#ifndef _WIN64 +#if !defined(_WIN64) && defined(BUILD_tcl) /* See [Bug 3354324]: file mtime sets wrong time */ # define _USE_32BIT_TIME_T #endif +/* + * We must specify the lower version we intend to support. + * + * WINVER = 0x0500 means Windows 2000 and above + */ + +#ifndef WINVER +# define WINVER 0x0501 +#endif +#ifndef _WIN32_WINNT +# define _WIN32_WINNT 0x0501 +#endif + #define WIN32_LEAN_AND_MEAN #include <windows.h> #undef WIN32_LEAN_AND_MEAN @@ -34,6 +47,10 @@ typedef DWORD_PTR * PDWORD_PTR; */ #define INCL_WINSOCK_API_TYPEDEFS 1 #include <winsock2.h> +#include <ws2tcpip.h> +#ifdef HAVE_WSPIAPI_H +# include <wspiapi.h> +#endif #ifdef CHECK_UNICODE_CALLS # define _UNICODE @@ -45,6 +62,20 @@ typedef DWORD_PTR * PDWORD_PTR; #endif /* CHECK_UNICODE_CALLS */ /* + * Pull in the typedef of TCHAR for windows. + */ +#include <tchar.h> +#ifndef _TCHAR_DEFINED + /* Borland seems to forget to set this. */ + typedef _TCHAR TCHAR; +# define _TCHAR_DEFINED +#endif +#if defined(_MSC_VER) && defined(__STDC__) + /* VS2005 SP1 misses this. See [Bug #3110161] */ + typedef _TCHAR TCHAR; +#endif + +/* *--------------------------------------------------------------------------- * The following sets of #includes and #ifdefs are required to get Tcl to * compile under the windows compilers. @@ -52,16 +83,14 @@ typedef DWORD_PTR * PDWORD_PTR; */ #include <time.h> +#include <wchar.h> #include <io.h> -#include <stdio.h> -#include <stdlib.h> #include <errno.h> #include <fcntl.h> #include <float.h> #include <malloc.h> #include <process.h> #include <signal.h> -#include <string.h> #include <limits.h> #ifndef __GNUC__ @@ -85,108 +114,166 @@ typedef DWORD_PTR * PDWORD_PTR; #endif /* __MWERKS__ */ /* - * Define EINPROGRESS in terms of WSAEINPROGRESS. - */ - -#undef EINPROGRESS -#define EINPROGRESS WSAEINPROGRESS - -/* - * Define ENOTSUP to a value that will never occur. - */ - -#undef ENOTSUP -#define ENOTSUP -1030507 - -/* Those codes, from Visual Studio 2010, conflict with other values */ -#undef ENODATA -#undef ENOMSG -#undef ENOSR -#undef ENOSTR -#undef EPROTO - -/* * The following defines redefine the Windows Socket errors as * BSD errors so Tcl_PosixError can do the right thing. */ -#undef EWOULDBLOCK -#define EWOULDBLOCK EAGAIN -#undef EALREADY -#define EALREADY 149 /* operation already in progress */ -#undef ENOTSOCK -#define ENOTSOCK 95 /* Socket operation on non-socket */ -#undef EDESTADDRREQ -#define EDESTADDRREQ 96 /* Destination address required */ -#undef EMSGSIZE -#define EMSGSIZE 97 /* Message too long */ -#undef EPROTOTYPE -#define EPROTOTYPE 98 /* Protocol wrong type for socket */ -#undef ENOPROTOOPT -#define ENOPROTOOPT 99 /* Protocol not available */ -#undef EPROTONOSUPPORT -#define EPROTONOSUPPORT 120 /* Protocol not supported */ -#undef ESOCKTNOSUPPORT -#define ESOCKTNOSUPPORT 121 /* Socket type not supported */ -#undef EOPNOTSUPP -#define EOPNOTSUPP 122 /* Operation not supported on socket */ -#undef EPFNOSUPPORT -#define EPFNOSUPPORT 123 /* Protocol family not supported */ -#undef EAFNOSUPPORT -#define EAFNOSUPPORT 124 /* Address family not supported */ -#undef EADDRINUSE -#define EADDRINUSE 125 /* Address already in use */ -#undef EADDRNOTAVAIL -#define EADDRNOTAVAIL 126 /* Can't assign requested address */ -#undef ENETDOWN -#define ENETDOWN 127 /* Network is down */ -#undef ENETUNREACH -#define ENETUNREACH 128 /* Network is unreachable */ -#undef ENETRESET -#define ENETRESET 129 /* Network dropped connection on reset */ -#undef ECONNABORTED -#define ECONNABORTED 130 /* Software caused connection abort */ -#undef ECONNRESET -#define ECONNRESET 131 /* Connection reset by peer */ -#undef ENOBUFS -#define ENOBUFS 132 /* No buffer space available */ -#undef EISCONN -#define EISCONN 133 /* Socket is already connected */ -#undef ENOTCONN -#define ENOTCONN 134 /* Socket is not connected */ -#undef ESHUTDOWN -#define ESHUTDOWN 143 /* Can't send after socket shutdown */ -#undef ETOOMANYREFS -#define ETOOMANYREFS 144 /* Too many references: can't splice */ -#undef ETIMEDOUT -#define ETIMEDOUT 145 /* Connection timed out */ -#undef ECONNREFUSED -#define ECONNREFUSED 146 /* Connection refused */ -#undef ELOOP -#define ELOOP 90 /* Symbolic link loop */ -#undef EHOSTDOWN -#define EHOSTDOWN 147 /* Host is down */ -#undef EHOSTUNREACH -#define EHOSTUNREACH 148 /* No route to host */ -#undef ENOTEMPTY -#define ENOTEMPTY 93 /* directory not empty */ -#undef EUSERS -#define EUSERS 94 /* Too many users (for UFS) */ -#undef EDQUOT -#define EDQUOT 69 /* Disc quota exceeded */ -#undef ESTALE -#define ESTALE 151 /* Stale NFS file handle */ -#undef EREMOTE -#define EREMOTE 66 /* The object is remote */ +#ifndef ENOTEMPTY +# define ENOTEMPTY 41 /* Directory not empty */ +#endif +#ifndef EREMOTE +# define EREMOTE 66 /* The object is remote */ +#endif +#ifndef EPFNOSUPPORT +# define EPFNOSUPPORT 96 /* Protocol family not supported */ +#endif +#ifndef EADDRINUSE +# define EADDRINUSE 100 /* Address already in use */ +#endif +#ifndef EADDRNOTAVAIL +# define EADDRNOTAVAIL 101 /* Can't assign requested address */ +#endif +#ifndef EAFNOSUPPORT +# define EAFNOSUPPORT 102 /* Address family not supported */ +#endif +#ifndef EALREADY +# define EALREADY 103 /* Operation already in progress */ +#endif +#ifndef EBADMSG +# define EBADMSG 104 /* Not a data message */ +#endif +#ifndef ECANCELED +# define ECANCELED 105 /* Canceled */ +#endif +#ifndef ECONNABORTED +# define ECONNABORTED 106 /* Software caused connection abort */ +#endif +#ifndef ECONNREFUSED +# define ECONNREFUSED 107 /* Connection refused */ +#endif +#ifndef ECONNRESET +# define ECONNRESET 108 /* Connection reset by peer */ +#endif +#ifndef EDESTADDRREQ +# define EDESTADDRREQ 109 /* Destination address required */ +#endif +#ifndef EHOSTUNREACH +# define EHOSTUNREACH 110 /* No route to host */ +#endif +#ifndef EIDRM +# define EIDRM 111 /* Identifier removed */ +#endif +#ifndef EINPROGRESS +# define EINPROGRESS 112 /* Operation now in progress */ +#endif +#ifndef EISCONN +# define EISCONN 113 /* Socket is already connected */ +#endif +#ifndef ELOOP +# define ELOOP 114 /* Symbolic link loop */ +#endif +#ifndef EMSGSIZE +# define EMSGSIZE 115 /* Message too long */ +#endif +#ifndef ENETDOWN +# define ENETDOWN 116 /* Network is down */ +#endif +#ifndef ENETRESET +# define ENETRESET 117 /* Network dropped connection on reset */ +#endif +#ifndef ENETUNREACH +# define ENETUNREACH 118 /* Network is unreachable */ +#endif +#ifndef ENOBUFS +# define ENOBUFS 119 /* No buffer space available */ +#endif +#ifndef ENODATA +# define ENODATA 120 /* No data available */ +#endif +#ifndef ENOLINK +# define ENOLINK 121 /* Link has be severed */ +#endif +#ifndef ENOMSG +# define ENOMSG 122 /* No message of desired type */ +#endif +#ifndef ENOPROTOOPT +# define ENOPROTOOPT 123 /* Protocol not available */ +#endif +#ifndef ENOSR +# define ENOSR 124 /* Out of stream resources */ +#endif +#ifndef ENOSTR +# define ENOSTR 125 /* Not a stream device */ +#endif +#ifndef ENOTCONN +# define ENOTCONN 126 /* Socket is not connected */ +#endif +#ifndef ENOTRECOVERABLE +# define ENOTRECOVERABLE 127 /* Not recoverable */ +#endif +#ifndef ENOTSOCK +# define ENOTSOCK 128 /* Socket operation on non-socket */ +#endif +#ifndef ENOTSUP +# define ENOTSUP 129 /* Operation not supported */ +#endif +#ifndef EOPNOTSUPP +# define EOPNOTSUPP 130 /* Operation not supported on socket */ +#endif +#ifndef EOTHER +# define EOTHER 131 /* Other error */ +#endif +#ifndef EOVERFLOW +# define EOVERFLOW 132 /* File too big */ +#endif +#ifndef EOWNERDEAD +# define EOWNERDEAD 133 /* Owner dead */ +#endif +#ifndef EPROTO +# define EPROTO 134 /* Protocol error */ +#endif +#ifndef EPROTONOSUPPORT +# define EPROTONOSUPPORT 135 /* Protocol not supported */ +#endif +#ifndef EPROTOTYPE +# define EPROTOTYPE 136 /* Protocol wrong type for socket */ +#endif +#ifndef ETIME +# define ETIME 137 /* Timer expired */ +#endif +#ifndef ETIMEDOUT +# define ETIMEDOUT 138 /* Connection timed out */ +#endif +#ifndef ETXTBSY +# define ETXTBSY 139 /* Text file or pseudo-device busy */ +#endif +#ifndef EWOULDBLOCK +# define EWOULDBLOCK 140 /* Operation would block */ +#endif -/* - * It is very hard to determine how Windows reacts to attempting to - * set a file pointer outside the input datatype's representable - * region. So we fake the error code ourselves. - */ -#undef EOVERFLOW -#define EOVERFLOW EFBIG /* The object couldn't fit in the datatype */ +/* Visual Studio doesn't have these, so just choose some high numbers */ +#ifndef ESOCKTNOSUPPORT +# define ESOCKTNOSUPPORT 240 /* Socket type not supported */ +#endif +#ifndef ESHUTDOWN +# define ESHUTDOWN 241 /* Can't send after socket shutdown */ +#endif +#ifndef ETOOMANYREFS +# define ETOOMANYREFS 242 /* Too many references: can't splice */ +#endif +#ifndef EHOSTDOWN +# define EHOSTDOWN 243 /* Host is down */ +#endif +#ifndef EUSERS +# define EUSERS 244 /* Too many users (for UFS) */ +#endif +#ifndef EDQUOT +# define EDQUOT 245 /* Disc quota exceeded */ +#endif +#ifndef ESTALE +# define ESTALE 246 /* Stale NFS file handle */ +#endif /* * Signals not known to the standard ANSI signal.h. These are used @@ -273,6 +360,20 @@ typedef DWORD_PTR * PDWORD_PTR; # define S_IFLNK 0120000 /* Symbolic Link */ #endif +/* + * Windows compilers do not define S_IFBLK. However, Tcl uses it in + * GetTypeFromMode to identify blockSpecial devices based on the + * value in the statsbuf st_mode field. We have no other way to pass this + * from NativeStat on Windows so are forced to define it here. + * The definition here is essentially what is seen on Linux and MingW. + * XXX - the root problem is Tcl using Unix definitions instead of + * abstracting the structure into a platform independent one. Sigh - perhaps + * Tcl 9 + */ +#ifndef S_IFBLK +# define S_IFBLK (S_IFDIR | S_IFCHR) +#endif + #ifndef S_ISREG # ifdef S_IFREG # define S_ISREG(m) (((m) & S_IFMT) == S_IFREG) @@ -382,18 +483,9 @@ typedef DWORD_PTR * PDWORD_PTR; #if defined(_MSC_VER) && (_MSC_VER >= 1400) # pragma warning(disable:4244) # pragma warning(disable:4267) -# pragma warning(disable:4311) -# pragma warning(disable:4312) # 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/tclWinSerial.c b/win/tclWinSerial.c index 83f1866..fe416ff 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -93,17 +93,12 @@ typedef struct SerialInfo { * threads. */ OVERLAPPED osRead; /* OVERLAPPED structure for read operations. */ OVERLAPPED osWrite; /* OVERLAPPED structure for write operations */ + TclPipeThreadInfo *writeTI; /* Thread info structure of writer worker. */ HANDLE writeThread; /* Handle to writer thread. */ CRITICAL_SECTION csWrite; /* Writer thread synchronisation. */ HANDLE evWritable; /* Manual-reset event to signal when the * writer thread has finished waiting for the * current buffer to be written. */ - HANDLE evStartWriter; /* Auto-reset event used by the main thread to - * signal when the writer thread should - * attempt to write to the serial. */ - HANDLE evStopWriter; /* Auto-reset event used by the main thread to - * signal when the writer thread should close. - */ 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 @@ -173,16 +168,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 +192,7 @@ static int SerialBlockingWrite(SerialInfo *infoPtr, LPVOID buf, * based IO. */ -static Tcl_ChannelType serialChannelType = { +static const Tcl_ChannelType serialChannelType = { "serial", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ SerialCloseProc, /* Close proc. */ @@ -214,7 +209,7 @@ static Tcl_ChannelType serialChannelType = { NULL, /* handler proc. */ NULL, /* wide seek proc */ SerialThreadActionProc, /* thread action proc */ - NULL, /* truncate */ + NULL /* truncate */ }; /* @@ -374,7 +369,7 @@ SerialGetMilliseconds(void) { Tcl_Time time; - TclpGetTime(&time); + Tcl_GetTime(&time); return (time.sec * 1000 + time.usec / 1000); } @@ -527,7 +522,7 @@ SerialCheckProc( if (needEvent) { infoPtr->flags |= SERIAL_PENDING; - evPtr = (SerialEvent *) ckalloc(sizeof(SerialEvent)); + evPtr = ckalloc(sizeof(SerialEvent)); evPtr->header.proc = SerialEventProc; evPtr->infoPtr = infoPtr; Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); @@ -599,7 +594,6 @@ SerialCloseProc( int errorCode, result = 0; SerialInfo *infoPtr, **nextPtrPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - DWORD exitCode; errorCode = 0; @@ -609,56 +603,13 @@ SerialCloseProc( } serialPtr->validMask &= ~TCL_READABLE; - if (serialPtr->validMask & TCL_WRITABLE) { - /* - * Generally we cannot wait for a pending write operation because it - * may hang due to handshake - * WaitForSingleObject(serialPtr->evWritable, INFINITE); - */ - - /* - * The thread may have already closed on it's own. Check it's exit - * code. - */ - - GetExitCodeThread(serialPtr->writeThread, &exitCode); - - if (exitCode == STILL_ACTIVE) { - /* - * Set the stop event so that if the writer thread is blocked in - * SerialWriterThread on WaitForMultipleEvents, it will exit - * cleanly. - */ - - SetEvent(serialPtr->evStopWriter); - - /* - * Wait at most 20 milliseconds for the writer thread to close. - */ - - if (WaitForSingleObject(serialPtr->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. - */ + if (serialPtr->writeThread) { - Tcl_MutexLock(&serialMutex); + TclPipeThreadStop(&serialPtr->writeTI, serialPtr->writeThread); - /* BUG: this leaks memory */ - TerminateThread(serialPtr->writeThread, 0); - - Tcl_MutexUnlock(&serialMutex); - } - } - - CloseHandle(serialPtr->writeThread); CloseHandle(serialPtr->osWrite.hEvent); CloseHandle(serialPtr->evWritable); - CloseHandle(serialPtr->evStartWriter); - CloseHandle(serialPtr->evStopWriter); + CloseHandle(serialPtr->writeThread); serialPtr->writeThread = NULL; PurgeComm(serialPtr->handle, PURGE_TXABORT | PURGE_TXCLEAR); @@ -706,7 +657,7 @@ SerialCloseProc( ckfree(serialPtr->writeBuf); serialPtr->writeBuf = NULL; } - ckfree((char*) serialPtr); + ckfree(serialPtr); if (errorCode == 0) { return result; @@ -932,7 +883,7 @@ SerialInputProc( bufSize = cStat.cbInQue; } } else { - errno = *errorCode = EAGAIN; + errno = *errorCode = EWOULDBLOCK; return -1; } } else { @@ -996,7 +947,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,12 +1022,12 @@ SerialOutputProc( ckfree(infoPtr->writeBuf); } infoPtr->writeBufLen = toWrite; - infoPtr->writeBuf = ckalloc((unsigned int) toWrite); + infoPtr->writeBuf = ckalloc(toWrite); } memcpy(infoPtr->writeBuf, buf, (size_t) toWrite); infoPtr->toWrite = toWrite; ResetEvent(infoPtr->evWritable); - SetEvent(infoPtr->evStartWriter); + TclPipeThreadSignal(&infoPtr->writeTI); bytesWritten = (DWORD) toWrite; } else { @@ -1313,34 +1264,21 @@ static DWORD WINAPI SerialWriterThread( LPVOID arg) { - SerialInfo *infoPtr = (SerialInfo *)arg; - DWORD bytesWritten, toWrite, waitResult; + TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *)arg; + SerialInfo *infoPtr = NULL; /* access info only after success init/wait */ + DWORD bytesWritten, toWrite; char *buf; OVERLAPPED myWrite; /* Have an own OVERLAPPED in this thread. */ - HANDLE wEvents[2]; - - /* - * The stop event takes precedence by being first in the list. - */ - - wEvents[0] = infoPtr->evStopWriter; - wEvents[1] = infoPtr->evStartWriter; for (;;) { /* * Wait for the main thread to signal before attempting to write. */ - - waitResult = WaitForMultipleObjects(2, wEvents, FALSE, INFINITE); - - if (waitResult != (WAIT_OBJECT_0 + 1)) { - /* - * The start event was not signaled. It might be the stop event or - * an error, so exit. - */ - + if (!TclPipeThreadWaitForSignal(&pipeTI)) { + /* exit */ break; } + infoPtr = (SerialInfo *)pipeTI->clientData; buf = infoPtr->writeBuf; toWrite = infoPtr->toWrite; @@ -1404,6 +1342,9 @@ SerialWriterThread( Tcl_MutexUnlock(&serialMutex); } + /* Worker exit, so inform the main thread or free TI-structure (if owned) */ + TclPipeThreadExit(&pipeTI); + return 0; } @@ -1415,7 +1356,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 +1368,7 @@ SerialWriterThread( HANDLE TclWinSerialOpen( HANDLE handle, - CONST TCHAR *name, + const TCHAR *name, DWORD access) { SerialInit(); @@ -1446,8 +1387,8 @@ TclWinSerialOpen( * finished */ - handle = (*tclWinProcs->createFileProc)(name, access, 0, 0, - OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0); + handle = CreateFile(name, access, 0, 0, OPEN_EXISTING, + FILE_FLAG_OVERLAPPED, 0); return handle; } @@ -1477,11 +1418,10 @@ TclWinOpenSerialChannel( int permissions) { SerialInfo *infoPtr; - DWORD id; SerialInit(); - infoPtr = (SerialInfo *) ckalloc((unsigned) sizeof(SerialInfo)); + infoPtr = ckalloc(sizeof(SerialInfo)); memset(infoPtr, 0, sizeof(SerialInfo)); infoPtr->validMask = permissions; @@ -1502,10 +1442,10 @@ TclWinOpenSerialChannel( * are shared between multiple channels (stdin/stdout). */ - sprintf(channelName, "file%" TCL_I_MODIFIER "x", (size_t)infoPtr); + sprintf(channelName, "file%" TCL_I_MODIFIER "x", (size_t) infoPtr); infoPtr->channel = Tcl_CreateChannel(&serialChannelType, channelName, - (ClientData) infoPtr, permissions); + infoPtr, permissions); SetupComm(handle, infoPtr->sysBufRead, infoPtr->sysBufWrite); @@ -1529,10 +1469,9 @@ TclWinOpenSerialChannel( infoPtr->osWrite.hEvent = CreateEvent(NULL, TRUE, FALSE, NULL); infoPtr->evWritable = CreateEvent(NULL, TRUE, TRUE, NULL); - infoPtr->evStartWriter = CreateEvent(NULL, FALSE, FALSE, NULL); - infoPtr->evStopWriter = CreateEvent(NULL, FALSE, FALSE, NULL); infoPtr->writeThread = CreateThread(NULL, 256, SerialWriterThread, - infoPtr, 0, &id); + TclPipeThreadCreateTI(&infoPtr->writeTI, infoPtr, + infoPtr->evWritable), 0, NULL); } /* @@ -1648,17 +1587,17 @@ static int SerialSetOptionProc( ClientData instanceData, /* File state. */ Tcl_Interp *interp, /* For error reporting - can be NULL. */ - CONST char *optionName, /* Which option to set? */ - CONST char *value) /* New value for option. */ + const char *optionName, /* Which option to set? */ + const char *value) /* New value for option. */ { SerialInfo *infoPtr; DCB dcb; BOOL result, flag; size_t len, vlen; Tcl_DString ds; - CONST TCHAR *native; + const TCHAR *native; int argc; - CONST char **argv; + const char **argv; infoPtr = (SerialInfo *) instanceData; @@ -1676,19 +1615,18 @@ SerialSetOptionProc( if ((len > 2) && (strncmp(optionName, "-mode", len) == 0)) { if (!GetCommState(infoPtr->handle, &dcb)) { - if (interp != NULL) { - Tcl_AppendResult(interp, "can't get comm state", NULL); - } - return TCL_ERROR; + goto getStateFailed; } native = Tcl_WinUtfToTChar(value, -1, &ds); - result = (*tclWinProcs->buildCommDCBProc)(native, &dcb); + result = BuildCommDCB(native, &dcb); Tcl_DStringFree(&ds); if (result == FALSE) { if (interp != NULL) { - Tcl_AppendResult(interp, "bad value \"", value, - "\" for -mode: should be baud,parity,data,stop", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad value \"%s\" for -mode: should be baud,parity,data,stop", + value)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL); } return TCL_ERROR; } @@ -1703,10 +1641,7 @@ SerialSetOptionProc( dcb.fAbortOnError = FALSE; if (!SetCommState(infoPtr->handle, &dcb)) { - if (interp != NULL) { - Tcl_AppendResult(interp, "can't set comm state", NULL); - } - return TCL_ERROR; + goto setStateFailed; } return TCL_OK; } @@ -1717,10 +1652,7 @@ SerialSetOptionProc( if ((len > 1) && (strncmp(optionName, "-handshake", len) == 0)) { if (!GetCommState(infoPtr->handle, &dcb)) { - if (interp != NULL) { - Tcl_AppendResult(interp, "can't get comm state", NULL); - } - return TCL_ERROR; + goto getStateFailed; } /* @@ -1755,18 +1687,16 @@ SerialSetOptionProc( dcb.fDtrControl = DTR_CONTROL_HANDSHAKE; } else { if (interp != NULL) { - Tcl_AppendResult(interp, "bad value \"", value, - "\" for -handshake: must be one of xonxoff, rtscts, " - "dtrdsr or none", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad value \"%s\" for -handshake: must be one of" + " xonxoff, rtscts, dtrdsr or none", value)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "HANDSHAKE", NULL); } return TCL_ERROR; } if (!SetCommState(infoPtr->handle, &dcb)) { - if (interp != NULL) { - Tcl_AppendResult(interp, "can't set comm state", NULL); - } - return TCL_ERROR; + goto setStateFailed; } return TCL_OK; } @@ -1777,10 +1707,7 @@ SerialSetOptionProc( if ((len > 1) && (strncmp(optionName, "-xchar", len) == 0)) { if (!GetCommState(infoPtr->handle, &dcb)) { - if (interp != NULL) { - Tcl_AppendResult(interp, "can't get comm state", NULL); - } - return TCL_ERROR; + goto getStateFailed; } if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) { @@ -1789,11 +1716,12 @@ SerialSetOptionProc( if (argc != 2) { badXchar: if (interp != NULL) { - Tcl_AppendResult(interp, "bad value for -xchar: should be " - "a list of two elements with each a single character", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad value for -xchar: should be a list of" + " two elements with each a single character", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "XCHAR", NULL); } - ckfree((char *) argv); + ckfree(argv); return TCL_ERROR; } @@ -1824,13 +1752,10 @@ SerialSetOptionProc( } dcb.XoffChar = (char) character; } - ckfree((char *) argv); + ckfree(argv); if (!SetCommState(infoPtr->handle, &dcb)) { - if (interp != NULL) { - Tcl_AppendResult(interp, "can't set comm state", NULL); - } - return TCL_ERROR; + goto setStateFailed; } return TCL_OK; } @@ -1847,11 +1772,12 @@ SerialSetOptionProc( } if ((argc % 2) == 1) { if (interp != NULL) { - Tcl_AppendResult(interp, "bad value \"", value, - "\" for -ttycontrol: should be a list of " - "signal,value pairs", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad value \"%s\" for -ttycontrol: should be " + "a list of signal,value pairs", value)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "TTYCONTROL", NULL); } - ckfree((char *) argv); + ckfree(argv); return TCL_ERROR; } @@ -1864,7 +1790,10 @@ SerialSetOptionProc( if (!EscapeCommFunction(infoPtr->handle, (DWORD) (flag ? SETDTR : CLRDTR))) { if (interp != NULL) { - Tcl_AppendResult(interp, "can't set DTR signal", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can't set DTR signal", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", + "FCONFIGURE", "TTY_SIGNAL", NULL); } result = TCL_ERROR; break; @@ -1873,7 +1802,10 @@ SerialSetOptionProc( if (!EscapeCommFunction(infoPtr->handle, (DWORD) (flag ? SETRTS : CLRRTS))) { if (interp != NULL) { - Tcl_AppendResult(interp, "can't set RTS signal", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can't set RTS signal", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", + "FCONFIGURE", "TTY_SIGNAL", NULL); } result = TCL_ERROR; break; @@ -1882,15 +1814,20 @@ SerialSetOptionProc( if (!EscapeCommFunction(infoPtr->handle, (DWORD) (flag ? SETBREAK : CLRBREAK))) { if (interp != NULL) { - Tcl_AppendResult(interp,"can't set BREAK signal",NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can't set BREAK signal", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", + "FCONFIGURE", "TTY_SIGNAL", NULL); } result = TCL_ERROR; break; } } else { if (interp != NULL) { - Tcl_AppendResult(interp, "bad signal name \"", argv[i], - "\" for -ttycontrol: must be DTR, RTS or BREAK", + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad signal name \"%s\" for -ttycontrol: must be" + " DTR, RTS or BREAK", argv[i])); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "TTY_SIGNAL", NULL); } result = TCL_ERROR; @@ -1898,7 +1835,7 @@ SerialSetOptionProc( } } - ckfree((char *) argv); + ckfree(argv); return result; } @@ -1924,20 +1861,24 @@ SerialSetOptionProc( inSize = atoi(argv[0]); outSize = atoi(argv[1]); } - ckfree((char *) argv); + ckfree(argv); if ((argc < 1) || (argc > 2) || (inSize <= 0) || (outSize <= 0)) { if (interp != NULL) { - Tcl_AppendResult(interp, "bad value \"", value, - "\" for -sysbuffer: should be a list of one or two " - "integers > 0", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad value \"%s\" for -sysbuffer: should be " + "a list of one or two integers > 0", value)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "SYS_BUFFER", NULL); } return TCL_ERROR; } if (!SetupComm(infoPtr->handle, inSize, outSize)) { if (interp != NULL) { - Tcl_AppendResult(interp, "can't setup comm buffers", NULL); + TclWinConvertError(GetLastError()); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't setup comm buffers: %s", + Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -1950,18 +1891,12 @@ SerialSetOptionProc( */ if (!GetCommState(infoPtr->handle, &dcb)) { - if (interp != NULL) { - Tcl_AppendResult(interp, "can't get comm state", NULL); - } - return TCL_ERROR; + goto getStateFailed; } dcb.XonLim = (WORD) (infoPtr->sysBufRead*1/2); dcb.XoffLim = (WORD) (infoPtr->sysBufRead*1/4); if (!SetCommState(infoPtr->handle, &dcb)) { - if (interp != NULL) { - Tcl_AppendResult(interp, "can't set comm state", NULL); - } - return TCL_ERROR; + goto setStateFailed; } return TCL_OK; } @@ -1991,7 +1926,10 @@ SerialSetOptionProc( tout.ReadTotalTimeoutConstant = msec; if (!SetCommTimeouts(infoPtr->handle, &tout)) { if (interp != NULL) { - Tcl_AppendResult(interp, "can't set comm timeouts", NULL); + TclWinConvertError(GetLastError()); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't set comm timeouts: %s", + Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -2001,6 +1939,22 @@ SerialSetOptionProc( return Tcl_BadChannelOption(interp, optionName, "mode handshake pollinterval sysbuffer timeout ttycontrol xchar"); + + getStateFailed: + if (interp != NULL) { + TclWinConvertError(GetLastError()); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get comm state: %s", Tcl_PosixError(interp))); + } + return TCL_ERROR; + + setStateFailed: + if (interp != NULL) { + TclWinConvertError(GetLastError()); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't set comm state: %s", Tcl_PosixError(interp))); + } + return TCL_ERROR; } /* @@ -2028,7 +1982,7 @@ static int SerialGetOptionProc( ClientData instanceData, /* File state. */ Tcl_Interp *interp, /* For error reporting - can be NULL. */ - CONST char *optionName, /* Option to get. */ + const char *optionName, /* Option to get. */ Tcl_DString *dsPtr) /* Where to store value(s). */ { SerialInfo *infoPtr; @@ -2053,12 +2007,14 @@ SerialGetOptionProc( } if (len==0 || (len>2 && (strncmp(optionName, "-mode", len) == 0))) { char parity; - char *stop; + const char *stop; char buf[2 * TCL_INTEGER_SPACE + 16]; if (!GetCommState(infoPtr->handle, &dcb)) { if (interp != NULL) { - Tcl_AppendResult(interp, "can't get comm state", NULL); + TclWinConvertError(GetLastError()); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get comm state: %s", Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -2126,7 +2082,9 @@ SerialGetOptionProc( if (!GetCommState(infoPtr->handle, &dcb)) { if (interp != NULL) { - Tcl_AppendResult(interp, "can't get comm state", NULL); + TclWinConvertError(GetLastError()); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get comm state: %s", Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -2202,7 +2160,9 @@ SerialGetOptionProc( if (!GetCommModemStatus(infoPtr->handle, &status)) { if (interp != NULL) { - Tcl_AppendResult(interp, "can't get tty status", NULL); + TclWinConvertError(GetLastError()); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get tty status: %s", Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -2212,10 +2172,9 @@ SerialGetOptionProc( if (valid) { return TCL_OK; - } else { - return Tcl_BadChannelOption(interp, optionName, - "mode pollinterval lasterror queue sysbuffer ttystatus xchar"); } + return Tcl_BadChannelOption(interp, optionName, + "mode pollinterval lasterror queue sysbuffer ttystatus xchar"); } /* diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 8f565b9..e2479e81 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -9,6 +9,9 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * ----------------------------------------------------------------------- + * The order and naming of functions in this file should minimize + * the file diff to tclUnixSock.c. + * ----------------------------------------------------------------------- * * General information on how this module works. * @@ -68,64 +71,126 @@ #undef setsockopt /* + * Helper macros to make parts of this file clearer. The macros do exactly + * what they say on the tin. :-) They also only ever refer to their arguments + * once, and so can be used without regard to side effects. + */ + +#define SET_BITS(var, bits) ((var) |= (bits)) +#define CLEAR_BITS(var, bits) ((var) &= ~(bits)) + +/* "sock" + a pointer in hex + \0 */ +#define SOCK_CHAN_LENGTH (4 + sizeof(void *) * 2 + 1) +#define SOCK_TEMPLATE "sock%p" + +/* * The following variable is used to tell whether this module has been * initialized. If 1, initialization of sockets was successful, if -1 then * socket initialization failed (WSAStartup failed). */ static int initialized = 0; +static const TCHAR classname[] = TEXT("TclSocket"); TCL_DECLARE_MUTEX(socketMutex) /* - * The following variable holds the network name of this host. + * The following defines declare the messages used on socket windows. */ -static TclInitProcessGlobalValueProc InitializeHostName; -static ProcessGlobalValue hostName = { - 0, 0, NULL, NULL, InitializeHostName, NULL, NULL -}; +#define SOCKET_MESSAGE WM_USER+1 +#define SOCKET_SELECT WM_USER+2 +#define SOCKET_TERMINATE WM_USER+3 +#define SELECT TRUE +#define UNSELECT FALSE /* - * The following defines declare the messages used on socket windows. + * This is needed to comply with the strict aliasing rules of GCC, but it also + * simplifies casting between the different sockaddr types. */ -#define SOCKET_MESSAGE WM_USER+1 -#define SOCKET_SELECT WM_USER+2 -#define SOCKET_TERMINATE WM_USER+3 -#define SELECT TRUE -#define UNSELECT FALSE +typedef union { + struct sockaddr sa; + struct sockaddr_in sa4; + struct sockaddr_in6 sa6; + struct sockaddr_storage sas; +} address; + +#ifndef IN6_ARE_ADDR_EQUAL +#define IN6_ARE_ADDR_EQUAL IN6_ADDR_EQUAL +#endif /* - * The following structure is used to store the data associated with each - * socket. - * All members modified by the notifier thread are defined as volatile. + * This structure describes per-instance state of a tcp based channel. */ -typedef struct SocketInfo { +typedef struct TcpState TcpState; + +typedef struct TcpFdList { + TcpState *statePtr; + SOCKET fd; + struct TcpFdList *next; +} TcpFdList; + +struct TcpState { Tcl_Channel channel; /* Channel associated with this socket. */ - SOCKET socket; /* Windows SOCKET handle. */ - volatile int flags; /* Bit field comprised of the flags described + struct TcpFdList *sockets; /* Windows SOCKET handle. */ + int flags; /* Bit field comprised of the flags described * below. */ int watchEvents; /* OR'ed combination of FD_READ, FD_WRITE, * FD_CLOSE, FD_ACCEPT and FD_CONNECT that * indicate which events are interesting. */ volatile int readyEvents; /* OR'ed combination of FD_READ, FD_WRITE, * FD_CLOSE, FD_ACCEPT and FD_CONNECT that - * indicate which events have occurred. */ + * indicate which events have occurred. + * Set by notifier thread, access must be + * protected by semaphore */ int selectEvents; /* OR'ed combination of FD_READ, FD_WRITE, * FD_CLOSE, FD_ACCEPT and FD_CONNECT that * indicate which events are currently being * selected. */ volatile int acceptEventCount; /* Count of the current number of FD_ACCEPTs - * that have arrived and not yet processed. */ + * that have arrived and not yet processed. + * Set by notifier thread, access must be + * protected by semaphore */ Tcl_TcpAcceptProc *acceptProc; /* Proc to call on accept. */ ClientData acceptProcData; /* The data for the accept proc. */ - volatile int lastError; /* Error code from last message. */ - struct SocketInfo *nextPtr; /* The next socket on the per-thread socket + + /* + * Only needed for client sockets + */ + + struct addrinfo *addrlist; /* Addresses to connect to. */ + struct addrinfo *addr; /* Iterator over addrlist. */ + struct addrinfo *myaddrlist;/* Local address. */ + struct addrinfo *myaddr; /* Iterator over myaddrlist. */ + int connectError; /* Cache status of async socket. */ + int cachedBlocking; /* Cache blocking mode of async socket. */ + volatile int notifierConnectError; + /* Async connect error set by notifier thread. + * This error is still a windows error code. + * Access must be protected by semaphore */ + struct TcpState *nextPtr; /* The next socket on the per-thread socket * list. */ -} SocketInfo; +}; + +/* + * These bits may be ORed together into the "flags" field of a TcpState + * structure. + */ + +#define TCP_NONBLOCKING (1<<0) /* Socket with non-blocking I/O */ +#define TCP_ASYNC_CONNECT (1<<1) /* Async connect in progress. */ +#define SOCKET_EOF (1<<2) /* A zero read happened on the + * socket. */ +#define SOCKET_PENDING (1<<3) /* A message has been sent for this + * socket */ +#define TCP_ASYNC_PENDING (1<<4) /* TcpConnect was called to + * process an async connect. This + * flag indicates that reentry is + * still pending */ +#define TCP_ASYNC_FAILED (1<<5) /* An async connect finally failed */ /* * The following structure is what is added to the Tcl event queue when a @@ -136,8 +201,8 @@ typedef struct { Tcl_Event header; /* Information that is standard for all * events. */ SOCKET socket; /* Socket descriptor that is ready. Used to - * find the SocketInfo structure for the file - * (can't point directly to the SocketInfo + * find the TcpState structure for the file + * (can't point directly to the TcpState * structure because it could go away while * the event is queued). */ } SocketEvent; @@ -148,17 +213,6 @@ typedef struct { #define TCP_BUFFER_SIZE 4096 -/* - * The following macros may be used to set the flags field of a SocketInfo - * structure. - */ - -#define SOCKET_ASYNC (1<<0) /* The socket is in blocking mode. */ -#define SOCKET_EOF (1<<1) /* A zero read happened on the - * socket. */ -#define SOCKET_ASYNC_CONNECT (1<<2) /* This socket uses async connect. */ -#define SOCKET_PENDING (1<<3) /* A message has been sent for this - * socket */ typedef struct { HWND hwnd; /* Handle to window for socket messages. */ @@ -169,11 +223,11 @@ typedef struct { * socketThread has been initialized and has * started. */ HANDLE socketListLock; /* Win32 Event to lock the socketList */ - SocketInfo *pendingSocketInfo; + TcpState *pendingTcpState; /* This socket is opened but not jet in the * list. This value is also checked by * the event structure. */ - SocketInfo *socketList; /* Every open socket in this thread has an + TcpState *socketList; /* Every open socket in this thread has an * entry on this list. */ } ThreadSpecificData; @@ -181,23 +235,23 @@ static Tcl_ThreadDataKey dataKey; static WNDCLASS windowClass; /* - * Static functions defined in this file. + * Static routines for this file: */ -static SocketInfo * CreateSocket(Tcl_Interp *interp, int port, - const char *host, int server, const char *myaddr, - int myport, int async); -static int CreateSocketAddress(LPSOCKADDR_IN sockaddrPtr, - const char *host, int port); +static int TcpConnect(Tcl_Interp *interp, + TcpState *state); static void InitSockets(void); -static SocketInfo * NewSocketInfo(SOCKET socket); +static TcpState * NewSocketInfo(SOCKET socket); static void SocketExitHandler(ClientData clientData); static LRESULT CALLBACK SocketProc(HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam); static int SocketsEnabled(void); -static void TcpAccept(SocketInfo *infoPtr); -static int WaitForSocketEvent(SocketInfo *infoPtr, int events, +static void TcpAccept(TcpFdList *fds, SOCKET newSocket, address addr); +static int WaitForConnect(TcpState *statePtr, int *errorCodePtr); +static int WaitForSocketEvent(TcpState *statePtr, int events, int *errorCodePtr); +static void AddSocketInfoFd(TcpState *statePtr, SOCKET socket); +static int FindFDInList(TcpState *statePtr, SOCKET socket); static DWORD WINAPI SocketThread(LPVOID arg); static void TcpThreadActionProc(ClientData instanceData, int action); @@ -205,8 +259,9 @@ static void TcpThreadActionProc(ClientData instanceData, static Tcl_EventCheckProc SocketCheckProc; static Tcl_EventProc SocketEventProc; static Tcl_EventSetupProc SocketSetupProc; -static Tcl_DriverBlockModeProc TcpBlockProc; +static Tcl_DriverBlockModeProc TcpBlockModeProc; static Tcl_DriverCloseProc TcpCloseProc; +static Tcl_DriverClose2Proc TcpClose2Proc; static Tcl_DriverSetOptionProc TcpSetOptionProc; static Tcl_DriverGetOptionProc TcpGetOptionProc; static Tcl_DriverInputProc TcpInputProc; @@ -216,192 +271,180 @@ static Tcl_DriverGetHandleProc TcpGetHandleProc; /* * This structure describes the channel type structure for TCP socket - * based IO. + * based IO: */ -static Tcl_ChannelType tcpChannelType = { - "tcp", /* Type name. */ - TCL_CHANNEL_VERSION_5, /* v5 channel */ - TcpCloseProc, /* Close proc. */ - TcpInputProc, /* Input proc. */ - TcpOutputProc, /* Output proc. */ - NULL, /* Seek proc. */ - TcpSetOptionProc, /* Set option proc. */ - TcpGetOptionProc, /* Get option proc. */ - TcpWatchProc, /* Set up notifier to watch this channel. */ - TcpGetHandleProc, /* Get an OS handle from channel. */ - NULL, /* close2proc. */ - TcpBlockProc, /* Set socket into (non-)blocking mode. */ - NULL, /* flush proc. */ - NULL, /* handler proc. */ - NULL, /* wide seek proc */ - TcpThreadActionProc, /* thread action proc */ - NULL, /* truncate */ +static const Tcl_ChannelType tcpChannelType = { + "tcp", /* Type name. */ + TCL_CHANNEL_VERSION_5, /* v5 channel */ + TcpCloseProc, /* Close proc. */ + TcpInputProc, /* Input proc. */ + TcpOutputProc, /* Output proc. */ + NULL, /* Seek proc. */ + TcpSetOptionProc, /* Set option proc. */ + TcpGetOptionProc, /* Get option proc. */ + TcpWatchProc, /* Initialize notifier. */ + TcpGetHandleProc, /* Get OS handles out of channel. */ + TcpClose2Proc, /* Close2 proc. */ + TcpBlockModeProc, /* Set blocking or non-blocking mode.*/ + NULL, /* flush proc. */ + NULL, /* handler proc. */ + NULL, /* wide seek proc. */ + TcpThreadActionProc, /* thread action proc. */ + NULL /* truncate proc. */ }; + +/* + * The following variable holds the network name of this host. + */ + +static TclInitProcessGlobalValueProc InitializeHostName; +static ProcessGlobalValue hostName = + {0, 0, NULL, NULL, InitializeHostName, NULL, NULL}; + +/* + * Address print debug functions + */ +#if 0 +void printaddrinfo(struct addrinfo *ai, char *prefix) +{ + char host[NI_MAXHOST], port[NI_MAXSERV]; + getnameinfo(ai->ai_addr, ai->ai_addrlen, + host, sizeof(host), + port, sizeof(port), + NI_NUMERICHOST|NI_NUMERICSERV); +} +void printaddrinfolist(struct addrinfo *addrlist, char *prefix) +{ + struct addrinfo *ai; + for (ai = addrlist; ai != NULL; ai = ai->ai_next) { + printaddrinfo(ai, prefix); + } +} +#endif /* *---------------------------------------------------------------------- * - * InitSockets -- - * - * Initialize the socket module. If winsock startup is successful, - * registers the event window for the socket notifier code. + * InitializeHostName -- * - * Assumes socketMutex is held. + * This routine sets the process global value of the name of the local + * host on which the process is running. * * Results: * None. * - * Side effects: - * Initializes winsock, registers a new window class and creates a - * window for use in asynchronous socket notification. - * *---------------------------------------------------------------------- */ -static void -InitSockets(void) +void +InitializeHostName( + char **valuePtr, + int *lengthPtr, + Tcl_Encoding *encodingPtr) { - DWORD id; - ThreadSpecificData *tsdPtr = (ThreadSpecificData *) - TclThreadDataKeyGet(&dataKey); - - if (!initialized) { - initialized = 1; - TclCreateLateExitHandler(SocketExitHandler, (ClientData) NULL); + TCHAR tbuf[MAX_COMPUTERNAME_LENGTH + 1]; + DWORD length = MAX_COMPUTERNAME_LENGTH + 1; + Tcl_DString ds; + if (GetComputerName(tbuf, &length) != 0) { /* - * Create the async notification window with a new class. We must - * create a new class to avoid a Windows 95 bug that causes us to get - * the wrong message number for socket events if the message window is - * a subclass of a static control. + * Convert string from native to UTF then change to lowercase. */ - windowClass.style = 0; - windowClass.cbClsExtra = 0; - windowClass.cbWndExtra = 0; - windowClass.hInstance = TclWinGetTclInstance(); - windowClass.hbrBackground = NULL; - windowClass.lpszMenuName = NULL; - windowClass.lpszClassName = "TclSocket"; - windowClass.lpfnWndProc = SocketProc; - windowClass.hIcon = NULL; - windowClass.hCursor = NULL; - - if (!RegisterClassA(&windowClass)) { - TclWinConvertError(GetLastError()); - goto initFailure; - } - - } - - /* - * Check for per-thread initialization. - */ - - if (tsdPtr == NULL) { - tsdPtr = TCL_TSD_INIT(&dataKey); - tsdPtr->pendingSocketInfo = NULL; - tsdPtr->socketList = NULL; - tsdPtr->hwnd = NULL; - tsdPtr->threadId = Tcl_GetCurrentThread(); - tsdPtr->readyEvent = CreateEvent(NULL, FALSE, FALSE, NULL); - if (tsdPtr->readyEvent == NULL) { - goto initFailure; - } - tsdPtr->socketListLock = CreateEvent(NULL, FALSE, TRUE, NULL); - if (tsdPtr->socketListLock == NULL) { - goto initFailure; - } - tsdPtr->socketThread = CreateThread(NULL, 256, SocketThread, tsdPtr, - 0, &id); - if (tsdPtr->socketThread == NULL) { - goto initFailure; - } - - SetThreadPriority(tsdPtr->socketThread, THREAD_PRIORITY_HIGHEST); + Tcl_UtfToLower(Tcl_WinTCharToUtf(tbuf, -1, &ds)); - /* - * Wait for the thread to signal when the window has been created and - * if it is ready to go. - */ + } else { + Tcl_DStringInit(&ds); + if (TclpHasSockets(NULL) == TCL_OK) { + /* + * The buffer size of 256 is recommended by the MSDN page that + * documents gethostname() as being always adequate. + */ - WaitForSingleObject(tsdPtr->readyEvent, INFINITE); + Tcl_DString inDs; - if (tsdPtr->hwnd == NULL) { - goto initFailure; /* Trouble creating the window */ + Tcl_DStringInit(&inDs); + Tcl_DStringSetLength(&inDs, 256); + if (gethostname(Tcl_DStringValue(&inDs), + Tcl_DStringLength(&inDs)) == 0) { + Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&inDs), -1, + &ds); + } + Tcl_DStringFree(&inDs); } - - Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL); } - return; - initFailure: - TclpFinalizeSockets(); - initialized = -1; - return; + *encodingPtr = Tcl_GetEncoding(NULL, "utf-8"); + *lengthPtr = Tcl_DStringLength(&ds); + *valuePtr = ckalloc((*lengthPtr) + 1); + memcpy(*valuePtr, Tcl_DStringValue(&ds), (size_t)(*lengthPtr)+1); + Tcl_DStringFree(&ds); } /* *---------------------------------------------------------------------- * - * SocketsEnabled -- + * Tcl_GetHostName -- * - * Check that the WinSock was successfully initialized. + * Returns the name of the local host. * * Results: - * 1 if it is. + * A string containing the network name for this machine, or an empty + * string if we can't figure out the name. The caller must not modify or + * free this string. * * Side effects: - * None. + * Caches the name to return for future calls. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ -static int -SocketsEnabled(void) +const char * +Tcl_GetHostName(void) { - int enabled; - Tcl_MutexLock(&socketMutex); - enabled = (initialized == 1); - Tcl_MutexUnlock(&socketMutex); - return enabled; + return Tcl_GetString(TclGetProcessGlobalValue(&hostName)); } - /* *---------------------------------------------------------------------- * - * SocketExitHandler -- + * TclpHasSockets -- * - * Callback invoked during exit clean up to delete the socket - * communication window and to release the WinSock DLL. + * This function determines whether sockets are available on the current + * system and returns an error in interp if they are not. Note that + * interp may be NULL. * * Results: - * None. + * Returns TCL_OK if the system supports sockets, or TCL_ERROR with an + * error in interp (if non-NULL). * * Side effects: - * None. + * If not already prepared, initializes the TSD structure and socket + * message handling thread associated to the calling thread for the + * subsystem of the driver. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ -static void -SocketExitHandler( - ClientData clientData) /* Not used. */ +int +TclpHasSockets( + Tcl_Interp *interp) /* Where to write an error message if sockets + * are not present, or NULL if no such message + * is to be written. */ { Tcl_MutexLock(&socketMutex); - /* - * Make sure the socket event handling window is cleaned-up for, at - * most, this thread. - */ - - TclpFinalizeSockets(); - UnregisterClass("TclSocket", TclWinGetTclInstance()); - initialized = 0; + InitSockets(); Tcl_MutexUnlock(&socketMutex); + + if (SocketsEnabled()) { + return TCL_OK; + } + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "sockets are not available on this system", -1)); + } + return TCL_ERROR; } /* @@ -426,346 +469,490 @@ SocketExitHandler( void TclpFinalizeSockets(void) { - ThreadSpecificData *tsdPtr; + ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); - tsdPtr = (ThreadSpecificData *) TclThreadDataKeyGet(&dataKey); - if (tsdPtr != NULL) { - if (tsdPtr->socketThread != NULL) { - if (tsdPtr->hwnd != NULL) { - if (PostMessage(tsdPtr->hwnd, SOCKET_TERMINATE, 0, 0)) { - /* - * Wait for the thread to exit. This ensures that we are - * completely cleaned up before we leave this function. - */ - WaitForSingleObject(tsdPtr->readyEvent, INFINITE); - } - tsdPtr->hwnd = NULL; - } - CloseHandle(tsdPtr->socketThread); - tsdPtr->socketThread = NULL; - } - if (tsdPtr->readyEvent != NULL) { - CloseHandle(tsdPtr->readyEvent); - tsdPtr->readyEvent = NULL; - } - if (tsdPtr->socketListLock != NULL) { - CloseHandle(tsdPtr->socketListLock); - tsdPtr->socketListLock = NULL; + /* + * Careful! This is a finalizer! + */ + + if (tsdPtr == NULL) { + return; + } + + if (tsdPtr->socketThread != NULL) { + if (tsdPtr->hwnd != NULL) { + PostMessage(tsdPtr->hwnd, SOCKET_TERMINATE, 0, 0); + + /* + * Wait for the thread to exit. This ensures that we are + * completely cleaned up before we leave this function. + */ + + WaitForSingleObject(tsdPtr->readyEvent, INFINITE); + tsdPtr->hwnd = NULL; } - Tcl_DeleteEventSource(SocketSetupProc, SocketCheckProc, NULL); + CloseHandle(tsdPtr->socketThread); + tsdPtr->socketThread = NULL; + } + if (tsdPtr->readyEvent != NULL) { + CloseHandle(tsdPtr->readyEvent); + tsdPtr->readyEvent = NULL; + } + if (tsdPtr->socketListLock != NULL) { + CloseHandle(tsdPtr->socketListLock); + tsdPtr->socketListLock = NULL; } + Tcl_DeleteEventSource(SocketSetupProc, SocketCheckProc, NULL); } /* *---------------------------------------------------------------------- * - * TclpHasSockets -- + * TcpBlockModeProc -- * - * This function determines whether sockets are available on the current - * system and returns an error in interp if they are not. Note that - * interp may be NULL. + * This function is invoked by the generic IO level to set blocking and + * nonblocking mode on a TCP socket based channel. * * Results: - * Returns TCL_OK if the system supports sockets, or TCL_ERROR with an - * error in interp (if non-NULL). + * 0 if successful, errno when failed. * * Side effects: - * If not already prepared, initializes the TSD structure and socket - * message handling thread associated to the calling thread for the - * subsystem of the driver. + * Sets the device into blocking or nonblocking mode. * *---------------------------------------------------------------------- */ -int -TclpHasSockets( - Tcl_Interp *interp) /* Where to write an error message if sockets - * are not present, or NULL if no such message - * is to be written. */ + /* ARGSUSED */ +static int +TcpBlockModeProc( + ClientData instanceData, /* Socket state. */ + int mode) /* The mode to set. Can be one of + * TCL_MODE_BLOCKING or + * TCL_MODE_NONBLOCKING. */ { - Tcl_MutexLock(&socketMutex); - InitSockets(); - Tcl_MutexUnlock(&socketMutex); + TcpState *statePtr = instanceData; - if (SocketsEnabled()) { - return TCL_OK; - } - if (interp != NULL) { - Tcl_AppendResult(interp, "sockets are not available on this system", - NULL); + if (mode == TCL_MODE_NONBLOCKING) { + statePtr->flags |= TCP_NONBLOCKING; + } else { + statePtr->flags &= ~(TCP_NONBLOCKING); } - return TCL_ERROR; + return 0; } /* *---------------------------------------------------------------------- * - * SocketSetupProc -- + * WaitForConnect -- * - * This function is invoked before Tcl_DoOneEvent blocks waiting for an - * event. + * Check the state of an async connect process. If a connection + * attempt terminated, process it, which may finalize it or may + * start the next attempt. If a connect error occures, it is saved + * in statePtr->connectError to be reported by 'fconfigure -error'. + * + * There are two modes of operation, defined by errorCodePtr: + * * non-NULL: Called by explicite read/write command. block if + * socket is blocking. + * May return two error codes: + * * EWOULDBLOCK: if connect is still in progress + * * ENOTCONN: if connect failed. This would be the error + * message of a rect or sendto syscall so this is + * emulated here. + * * Null: Called by a backround operation. Do not block and + * don't return any error code. * * Results: - * None. + * 0 if the connection has completed, -1 if still in progress + * or there is an error. * * Side effects: - * Adjusts the block time if needed. + * Processes socket events off the system queue. + * May process asynchroneous connect. * *---------------------------------------------------------------------- */ -void -SocketSetupProc( - ClientData data, /* Not used. */ - int flags) /* Event flags as passed to Tcl_DoOneEvent. */ +static int +WaitForConnect( + TcpState *statePtr, /* State of the socket. */ + int *errorCodePtr) /* Where to store errors? + * A passed null-pointer activates background mode. + */ { - SocketInfo *infoPtr; - Tcl_Time blockTime = { 0, 0 }; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + int result; + int oldMode; + ThreadSpecificData *tsdPtr; - if (!(flags & TCL_FILE_EVENTS)) { - return; + /* + * Check if an async connect failed already and error reporting is demanded, + * return the error ENOTCONN + */ + + if (errorCodePtr != NULL && (statePtr->flags & TCP_ASYNC_FAILED)) { + *errorCodePtr = ENOTCONN; + return -1; } /* - * Check to see if there is a ready socket. If so, poll. + * Check if an async connect is running. If not return ok */ - WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - for (infoPtr = tsdPtr->socketList; infoPtr != NULL; - infoPtr = infoPtr->nextPtr) { - if (infoPtr->readyEvents & infoPtr->watchEvents) { - Tcl_SetMaxBlockTime(&blockTime); - break; - } + if (!(statePtr->flags & TCP_ASYNC_CONNECT)) { + return 0; } - SetEvent(tsdPtr->socketListLock); -} - -/* - *---------------------------------------------------------------------- - * - * SocketCheckProc -- - * - * This function is called by Tcl_DoOneEvent to check the socket event - * source for events. - * - * Results: - * None. - * - * Side effects: - * May queue an event. - * - *---------------------------------------------------------------------- - */ -static void -SocketCheckProc( - ClientData data, /* Not used. */ - int flags) /* Event flags as passed to Tcl_DoOneEvent. */ -{ - SocketInfo *infoPtr; - SocketEvent *evPtr; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + /* + * Be sure to disable event servicing so we are truly modal. + */ - if (!(flags & TCL_FILE_EVENTS)) { - return; - } + oldMode = Tcl_SetServiceMode(TCL_SERVICE_NONE); /* - * Queue events for any ready sockets that don't already have events - * queued (caused by persistent states that won't generate WinSock - * events). + * Loop in the blocking case until the connect signal is present */ - WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - for (infoPtr = tsdPtr->socketList; infoPtr != NULL; - infoPtr = infoPtr->nextPtr) { - if ((infoPtr->readyEvents & infoPtr->watchEvents) - && !(infoPtr->flags & SOCKET_PENDING)) { - infoPtr->flags |= SOCKET_PENDING; - evPtr = (SocketEvent *) ckalloc(sizeof(SocketEvent)); - evPtr->header.proc = SocketEventProc; - evPtr->socket = infoPtr->socket; - Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); + while (1) { + + /* get statePtr lock */ + tsdPtr = TclThreadDataKeyGet(&dataKey); + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + + /* Check for connect event */ + if (statePtr->readyEvents & FD_CONNECT) { + + /* Consume the connect event */ + statePtr->readyEvents &= ~(FD_CONNECT); + + /* + * For blocking sockets and foreground processing + * disable async connect as we continue now synchoneously + */ + if ( errorCodePtr != NULL && + ! (statePtr->flags & TCP_NONBLOCKING) ) { + CLEAR_BITS(statePtr->flags, TCP_ASYNC_CONNECT); + } + + /* Free list lock */ + SetEvent(tsdPtr->socketListLock); + + /* + * Continue connect. + * If switched to synchroneous connect, the connect is terminated. + */ + result = TcpConnect(NULL, statePtr); + + /* Restore event service mode */ + (void) Tcl_SetServiceMode(oldMode); + + /* + * Check for Succesfull connect or async connect restart + */ + + if (result == TCL_OK) { + /* + * Check for async connect restart + * (not possible for foreground blocking operation) + */ + if ( statePtr->flags & TCP_ASYNC_PENDING ) { + if (errorCodePtr != NULL) { + *errorCodePtr = EWOULDBLOCK; + } + return -1; + } + return 0; + } + + /* + * Connect finally failed. + * For foreground operation return ENOTCONN. + */ + + if (errorCodePtr != NULL) { + *errorCodePtr = ENOTCONN; + } + return -1; + } + + /* Free list lock */ + SetEvent(tsdPtr->socketListLock); + + /* + * Background operation returns with no action as there was no connect + * event + */ + + if ( errorCodePtr == NULL ) { + return -1; } + + /* + * A non blocking socket waiting for an asynchronous connect + * returns directly the error EWOULDBLOCK + */ + + if (statePtr->flags & TCP_NONBLOCKING) { + *errorCodePtr = EWOULDBLOCK; + return -1; + } + + /* + * Wait until something happens. + */ + + WaitForSingleObject(tsdPtr->readyEvent, INFINITE); } - SetEvent(tsdPtr->socketListLock); } /* *---------------------------------------------------------------------- * - * SocketEventProc -- + * TcpInputProc -- * - * This function is called by Tcl_ServiceEvent when a socket event - * reaches the front of the event queue. This function is responsible for - * notifying the generic channel code. + * This function is invoked by the generic IO level to read input from a + * TCP socket based channel. * * Results: - * Returns 1 if the event was handled, meaning it should be removed from - * the queue. Returns 0 if the event was not handled, meaning it should - * stay on the queue. The only time the event isn't handled is if the - * TCL_FILE_EVENTS flag bit isn't set. + * The number of bytes read is returned or -1 on error. An output + * argument contains the POSIX error code on error, or zero if no error + * occurred. * * Side effects: - * Whatever the channel callback functions do. + * Reads input from the input device of the channel. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ static int -SocketEventProc( - Tcl_Event *evPtr, /* Event to service. */ - int flags) /* Flags that indicate what events to handle, - * such as TCL_FILE_EVENTS. */ +TcpInputProc( + ClientData instanceData, /* Socket state. */ + char *buf, /* Where to store data read. */ + int bufSize, /* How much space is available in the + * buffer? */ + int *errorCodePtr) /* Where to store error code. */ { - SocketInfo *infoPtr; - SocketEvent *eventPtr = (SocketEvent *) evPtr; - int mask = 0; - int events; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + TcpState *statePtr = instanceData; + int bytesRead; + DWORD error; + ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); - if (!(flags & TCL_FILE_EVENTS)) { - return 0; - } + *errorCodePtr = 0; /* - * Find the specified socket on the socket list. + * Check that WinSock is initialized; do not call it if not, to prevent + * system crashes. This can happen at exit time if the exit handler for + * WinSock ran before other exit handlers that want to use sockets. */ - WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - for (infoPtr = tsdPtr->socketList; infoPtr != NULL; - infoPtr = infoPtr->nextPtr) { - if (infoPtr->socket == eventPtr->socket) { - break; - } + if (!SocketsEnabled()) { + *errorCodePtr = EFAULT; + return -1; } - SetEvent(tsdPtr->socketListLock); /* - * Discard events that have gone stale. + * First check to see if EOF was already detected, to prevent calling the + * socket stack after the first time EOF is detected. */ - if (!infoPtr) { - return 1; + if (statePtr->flags & SOCKET_EOF) { + return 0; } - infoPtr->flags &= ~SOCKET_PENDING; - /* - * Handle connection requests directly. + * Check if there is an async connect running. + * For blocking sockets terminate connect, otherwise do one step. + * For a non blocking socket return EWOULDBLOCK if connect not terminated */ - if (infoPtr->readyEvents & FD_ACCEPT) { - TcpAccept(infoPtr); - return 1; + if (WaitForConnect(statePtr, errorCodePtr) != 0) { + return -1; } /* - * Mask off unwanted events and compute the read/write mask so we can - * notify the channel. + * No EOF, and it is connected, so try to read more from the socket. Note + * that we clear the FD_READ bit because read events are level triggered + * so a new event will be generated if there is still data available to be + * read. We have to simulate blocking behavior here since we are always + * using non-blocking sockets. */ - events = infoPtr->readyEvents & infoPtr->watchEvents; + while (1) { + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, + (WPARAM) UNSELECT, (LPARAM) statePtr); + /* single fd operation: this proc is only called for a connected socket. */ + bytesRead = recv(statePtr->sockets->fd, buf, bufSize, 0); + statePtr->readyEvents &= ~(FD_READ); - if (events & FD_CLOSE) { /* - * If the socket was closed and the channel is still interested in - * read events, then we need to ensure that we keep polling for this - * event until someone does something with the channel. Note that we - * do this before calling Tcl_NotifyChannel so we don't have to watch - * out for the channel being deleted out from under us. This may cause - * a redundant trip through the event loop, but it's simpler than - * trying to do unwind protection. + * Check for end-of-file condition or successful read. */ - Tcl_Time blockTime = { 0, 0 }; - Tcl_SetMaxBlockTime(&blockTime); - mask |= TCL_READABLE|TCL_WRITABLE; - } else if (events & FD_READ) { + if (bytesRead == 0) { + statePtr->flags |= SOCKET_EOF; + } + if (bytesRead != SOCKET_ERROR) { + break; + } + /* - * Throw the readable event if an async connect failed. + * If an error occurs after the FD_CLOSE has arrived, then ignore the + * error and report an EOF. */ - if (infoPtr->lastError) { + if (statePtr->readyEvents & FD_CLOSE) { + statePtr->flags |= SOCKET_EOF; + bytesRead = 0; + break; + } - mask |= TCL_READABLE; - - } else { - fd_set readFds; - struct timeval timeout; + error = WSAGetLastError(); - /* - * We must check to see if data is really available, since someone - * could have consumed the data in the meantime. Turn off async - * notification so select will work correctly. If the socket is still - * readable, notify the channel driver, otherwise reset the async - * select handler and keep waiting. - */ + /* + * If an RST comes, then ignore the error and report an EOF just like + * on unix. + */ - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) UNSELECT, (LPARAM) infoPtr); + if (error == WSAECONNRESET) { + statePtr->flags |= SOCKET_EOF; + bytesRead = 0; + break; + } - FD_ZERO(&readFds); - FD_SET(infoPtr->socket, &readFds); - timeout.tv_usec = 0; - timeout.tv_sec = 0; + /* + * Check for error condition or underflow in non-blocking case. + */ - if (select(0, &readFds, NULL, NULL, &timeout) != 0) { - mask |= TCL_READABLE; - } else { - infoPtr->readyEvents &= ~(FD_READ); - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) SELECT, (LPARAM) infoPtr); - } + if ((statePtr->flags & TCP_NONBLOCKING) || (error != WSAEWOULDBLOCK)) { + TclWinConvertError(error); + *errorCodePtr = Tcl_GetErrno(); + bytesRead = -1; + break; } - } - /* - * writable event - */ + /* + * In the blocking case, wait until the file becomes readable or + * closed and try again. + */ - if (events & FD_WRITE) { - mask |= TCL_WRITABLE; + if (!WaitForSocketEvent(statePtr, FD_READ|FD_CLOSE, errorCodePtr)) { + bytesRead = -1; + break; + } } - if (mask) { - Tcl_NotifyChannel(infoPtr->channel, mask); - } - return 1; + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)statePtr); + + return bytesRead; } /* *---------------------------------------------------------------------- * - * TcpBlockProc -- + * TcpOutputProc -- * - * Sets a socket into blocking or non-blocking mode. + * This function is called by the generic IO level to write data to a + * socket based channel. * * Results: - * 0 if successful, errno if there was an error. + * The number of bytes written or -1 on failure. * * Side effects: - * None. + * Produces output on the socket. * *---------------------------------------------------------------------- */ static int -TcpBlockProc( - ClientData instanceData, /* The socket to block/un-block. */ - int mode) /* TCL_MODE_BLOCKING or - * TCL_MODE_NONBLOCKING. */ +TcpOutputProc( + ClientData instanceData, /* Socket state. */ + const char *buf, /* The data buffer. */ + int toWrite, /* How many bytes to write? */ + int *errorCodePtr) /* Where to store error code. */ { - SocketInfo *infoPtr = (SocketInfo *) instanceData; + TcpState *statePtr = instanceData; + int written; + DWORD error; + ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); - if (mode == TCL_MODE_NONBLOCKING) { - infoPtr->flags |= SOCKET_ASYNC; - } else { - infoPtr->flags &= ~(SOCKET_ASYNC); + *errorCodePtr = 0; + + /* + * Check that WinSock is initialized; do not call it if not, to prevent + * system crashes. This can happen at exit time if the exit handler for + * WinSock ran before other exit handlers that want to use sockets. + */ + + if (!SocketsEnabled()) { + *errorCodePtr = EFAULT; + return -1; } - return 0; + + /* + * Check if there is an async connect running. + * For blocking sockets terminate connect, otherwise do one step. + * For a non blocking socket return EWOULDBLOCK if connect not terminated + */ + + if (WaitForConnect(statePtr, errorCodePtr) != 0) { + return -1; + } + + while (1) { + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, + (WPARAM) UNSELECT, (LPARAM) statePtr); + + /* single fd operation: this proc is only called for a connected socket. */ + written = send(statePtr->sockets->fd, buf, toWrite, 0); + if (written != SOCKET_ERROR) { + /* + * Since Windows won't generate a new write event until we hit an + * overflow condition, we need to force the event loop to poll + * until the condition changes. + */ + + if (statePtr->watchEvents & FD_WRITE) { + Tcl_Time blockTime = { 0, 0 }; + Tcl_SetMaxBlockTime(&blockTime); + } + break; + } + + /* + * Check for error condition or overflow. In the event of overflow, we + * need to clear the FD_WRITE flag so we can detect the next writable + * event. Note that Windows only sends a new writable event after a + * send fails with WSAEWOULDBLOCK. + */ + + error = WSAGetLastError(); + if (error == WSAEWOULDBLOCK) { + statePtr->readyEvents &= ~(FD_WRITE); + if (statePtr->flags & TCP_NONBLOCKING) { + *errorCodePtr = EWOULDBLOCK; + written = -1; + break; + } + } else { + TclWinConvertError(error); + *errorCodePtr = Tcl_GetErrno(); + written = -1; + break; + } + + /* + * In the blocking case, wait until the file becomes writable or + * closed and try again. + */ + + if (!WaitForSocketEvent(statePtr, FD_WRITE|FD_CLOSE, errorCodePtr)) { + written = -1; + break; + } + } + + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)statePtr); + + return written; } /* @@ -792,7 +979,7 @@ TcpCloseProc( ClientData instanceData, /* The socket to close. */ Tcl_Interp *interp) /* Unused. */ { - SocketInfo *infoPtr = (SocketInfo *) instanceData; + TcpState *statePtr = instanceData; /* TIP #218 */ int errorCode = 0; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -810,24 +997,37 @@ TcpCloseProc( * background. */ - if (closesocket(infoPtr->socket) == SOCKET_ERROR) { - TclWinConvertWSAError((DWORD) WSAGetLastError()); - errorCode = Tcl_GetErrno(); + while ( statePtr->sockets != NULL ) { + TcpFdList *thisfd = statePtr->sockets; + statePtr->sockets = thisfd->next; + + if (closesocket(thisfd->fd) == SOCKET_ERROR) { + TclWinConvertError((DWORD) WSAGetLastError()); + errorCode = Tcl_GetErrno(); + } + ckfree(thisfd); } } + if (statePtr->addrlist != NULL) { + freeaddrinfo(statePtr->addrlist); + } + if (statePtr->myaddrlist != NULL) { + freeaddrinfo(statePtr->myaddrlist); + } + /* * Clear an eventual tsd info list pointer. * This may be called, if an async socket connect fails or is closed * between connect and thread action callback. */ - if (tsdPtr->pendingSocketInfo != NULL - && tsdPtr->pendingSocketInfo == infoPtr) { + if (tsdPtr->pendingTcpState != NULL + && tsdPtr->pendingTcpState == statePtr) { /* get infoPtr lock, because this concerns the notifier thread */ WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - tsdPtr->pendingSocketInfo = NULL; + tsdPtr->pendingTcpState = NULL; /* Free list lock */ SetEvent(tsdPtr->socketListLock); @@ -840,92 +1040,93 @@ TcpCloseProc( * fear of damaging the list. */ - ckfree((char *) infoPtr); + ckfree(statePtr); return errorCode; } /* *---------------------------------------------------------------------- * - * NewSocketInfo -- + * TcpClose2Proc -- * - * This function allocates and initializes a new SocketInfo structure. + * This function is called by the generic IO level to perform the channel + * type specific part of a half-close: namely, a shutdown() on a socket. * * Results: - * Returns a newly allocated SocketInfo. + * 0 if successful, the value of errno if failed. * * Side effects: - * None, except for allocation of memory. + * Shuts down one side of the socket. * *---------------------------------------------------------------------- */ -static SocketInfo * -NewSocketInfo( - SOCKET socket) +static int +TcpClose2Proc( + ClientData instanceData, /* The socket to close. */ + Tcl_Interp *interp, /* For error reporting. */ + int flags) /* Flags that indicate which side to close. */ { - SocketInfo *infoPtr; - /* ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); */ - - infoPtr = (SocketInfo *) ckalloc((unsigned) sizeof(SocketInfo)); - infoPtr->channel = 0; - infoPtr->socket = socket; - infoPtr->flags = 0; - infoPtr->watchEvents = 0; - infoPtr->readyEvents = 0; - infoPtr->selectEvents = 0; - infoPtr->acceptEventCount = 0; - infoPtr->acceptProc = NULL; - infoPtr->acceptProcData = NULL; - infoPtr->lastError = 0; + TcpState *statePtr = instanceData; + int errorCode = 0; + int sd; /* - * TIP #218. Removed the code inserting the new structure into the global - * list. This is now handled in the thread action callbacks, and only - * there. + * Shutdown the OS socket handle. */ - infoPtr->nextPtr = NULL; + switch(flags) { + case TCL_CLOSE_READ: + sd = SD_RECEIVE; + break; + case TCL_CLOSE_WRITE: + sd = SD_SEND; + break; + default: + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "socket close2proc called bidirectionally", -1)); + } + return TCL_ERROR; + } + + /* single fd operation: Tcl_OpenTcpServer() does not set TCL_READABLE or + * TCL_WRITABLE so this should never be called for a server socket. */ + if (shutdown(statePtr->sockets->fd, sd) == SOCKET_ERROR) { + TclWinConvertError((DWORD) WSAGetLastError()); + errorCode = Tcl_GetErrno(); + } - return infoPtr; + return errorCode; } /* *---------------------------------------------------------------------- * - * CreateSocket -- + * TcpSetOptionProc -- * - * This function opens a new socket and initializes the SocketInfo - * structure. + * Sets Tcp channel specific options. * * Results: - * Returns a new SocketInfo, or NULL with an error in interp. + * None, unless an error happens. * * Side effects: - * None, except for allocation of memory. + * Changes attributes of the socket at the system level. * *---------------------------------------------------------------------- */ -static SocketInfo * -CreateSocket( - Tcl_Interp *interp, /* For error reporting; can be NULL. */ - int port, /* Port number to open. */ - const char *host, /* Name of host on which to open port. */ - int server, /* 1 if socket should be a server socket, else - * 0 for a client socket. */ - const char *myaddr, /* Optional client-side address */ - int myport, /* Optional client-side port */ - int async) /* If nonzero, connect client socket - * asynchronously. */ +static int +TcpSetOptionProc( + ClientData instanceData, /* Socket state. */ + Tcl_Interp *interp, /* For error reporting - can be NULL. */ + const char *optionName, /* Name of the option to set. */ + const char *value) /* New value for option. */ { - u_long flag = 1; /* Indicates nonblocking mode. */ - SOCKADDR_IN sockaddr; /* Socket address */ - SOCKADDR_IN mysockaddr; /* Socket address for client */ - SOCKET sock = INVALID_SOCKET; - SocketInfo *infoPtr=NULL; /* The returned value. */ - ThreadSpecificData *tsdPtr = (ThreadSpecificData *) - TclThreadDataKeyGet(&dataKey); +#ifdef TCL_FEATURE_KEEPALIVE_NAGLE + TcpState *statePtr = instanceData; + SOCKET sock; +#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/ /* * Check that WinSock is initialized; do not call it if not, to prevent @@ -934,345 +1135,748 @@ CreateSocket( */ if (!SocketsEnabled()) { - return NULL; + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "winsock is not initialized", -1)); + } + return TCL_ERROR; } - if (!CreateSocketAddress(&sockaddr, host, port)) { - goto error; - } - if ((myaddr != NULL || myport != 0) && - !CreateSocketAddress(&mysockaddr, myaddr, myport)) { - goto error; - } +#ifdef TCL_FEATURE_KEEPALIVE_NAGLE + #error "TCL_FEATURE_KEEPALIVE_NAGLE not reviewed for whether to treat statePtr->sockets as single fd or list" + sock = statePtr->sockets->fd; - sock = socket(AF_INET, SOCK_STREAM, 0); - if (sock == INVALID_SOCKET) { - goto error; + if (!strcasecmp(optionName, "-keepalive")) { + BOOL val = FALSE; + int boolVar, rtn; + + if (Tcl_GetBoolean(interp, value, &boolVar) != TCL_OK) { + return TCL_ERROR; + } + if (boolVar) { + val = TRUE; + } + rtn = setsockopt(sock, SOL_SOCKET, SO_KEEPALIVE, + (const char *) &val, sizeof(BOOL)); + if (rtn != 0) { + TclWinConvertError(WSAGetLastError()); + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't set socket option: %s", + Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + return TCL_OK; + } else if (!strcasecmp(optionName, "-nagle")) { + BOOL val = FALSE; + int boolVar, rtn; + + if (Tcl_GetBoolean(interp, value, &boolVar) != TCL_OK) { + return TCL_ERROR; + } + if (!boolVar) { + val = TRUE; + } + rtn = setsockopt(sock, IPPROTO_TCP, TCP_NODELAY, + (const char *) &val, sizeof(BOOL)); + if (rtn != 0) { + TclWinConvertError(WSAGetLastError()); + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't set socket option: %s", + Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + return TCL_OK; } + return Tcl_BadChannelOption(interp, optionName, "keepalive nagle"); +#else + return Tcl_BadChannelOption(interp, optionName, ""); +#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/ +} + +/* + *---------------------------------------------------------------------- + * + * TcpGetOptionProc -- + * + * Computes an option value for a TCP socket based channel, or a list of + * all options and their values. + * + * Note: This code is based on code contributed by John Haxby. + * + * Results: + * A standard Tcl result. The value of the specified option or a list of + * all options and their values is returned in the supplied DString. Sets + * Error message if needed. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TcpGetOptionProc( + ClientData instanceData, /* Socket state. */ + Tcl_Interp *interp, /* For error reporting - can be NULL. */ + const char *optionName, /* Name of the option to retrieve the value + * for, or NULL to get all options and their + * values. */ + Tcl_DString *dsPtr) /* Where to store the computed value; + * initialized by caller. */ +{ + TcpState *statePtr = instanceData; + char host[NI_MAXHOST], port[NI_MAXSERV]; + SOCKET sock; + size_t len = 0; + int reverseDNS = 0; +#define SUPPRESS_RDNS_VAR "::tcl::unsupported::noReverseDNS" + /* - * Win-NT has a misfeature that sockets are inherited in child processes - * by default. Turn off the inherit bit. + * Check that WinSock is initialized; do not call it if not, to prevent + * system crashes. This can happen at exit time if the exit handler for + * WinSock ran before other exit handlers that want to use sockets. */ - SetHandleInformation((HANDLE) sock, HANDLE_FLAG_INHERIT, 0); + if (!SocketsEnabled()) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "winsock is not initialized", -1)); + } + return TCL_ERROR; + } /* - * Set kernel space buffering + * Go one step in async connect + * If any error is thrown save it as backround error to report eventually below */ + WaitForConnect(statePtr, NULL); - TclSockMinimumBuffers((void *)sock, TCP_BUFFER_SIZE); - - if (server) { - /* - * Bind to the specified port. Note that we must not call setsockopt - * with SO_REUSEADDR because Microsoft allows addresses to be reused - * even if they are still in use. - * - * Bind should not be affected by the socket having already been set - * into nonblocking mode. If there is trouble, this is one place to - * look for bugs. - */ + sock = statePtr->sockets->fd; + if (optionName != NULL) { + len = strlen(optionName); + } - if (bind(sock, (SOCKADDR *) &sockaddr, sizeof(SOCKADDR_IN)) - == SOCKET_ERROR) { - goto error; - } + if ((len > 1) && (optionName[1] == 'e') && + (strncmp(optionName, "-error", len) == 0)) { /* - * Set the maximum number of pending connect requests to the max value - * allowed on each platform (Win32 and Win32s may be different, and - * there may be differences between TCP/IP stacks). - */ + * Do not return any errors if async connect is running + */ + if ( ! (statePtr->flags & TCP_ASYNC_PENDING) ) { - if (listen(sock, SOMAXCONN) == SOCKET_ERROR) { - goto error; - } - /* - * Add this socket to the global list of sockets. - */ + if ( statePtr->flags & TCP_ASYNC_FAILED ) { - infoPtr = NewSocketInfo(sock); + /* + * In case of a failed async connect, eventually report the + * connect error only once. + * Do not report the system error, as this comes again and again. + */ - /* - * Set up the select mask for connection request events. - */ + if ( statePtr->connectError != 0 ) { + Tcl_DStringAppend(dsPtr, + Tcl_ErrnoMsg(statePtr->connectError), -1); + statePtr->connectError = 0; + } - infoPtr->selectEvents = FD_ACCEPT; - infoPtr->watchEvents |= FD_ACCEPT; + } else { - /* - * Register for interest in events in the select mask. Note that this - * automatically places the socket into non-blocking mode. - */ - - ioctlsocket(sock, (long) FIONBIO, &flag); - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, - (LPARAM) infoPtr); + /* + * Report an eventual last error of the socket system + */ - } else { - /* - * Try to bind to a local port, if specified. - */ + int optlen; + int ret; + DWORD err; - if (myaddr != NULL || myport != 0) { - if (bind(sock, (SOCKADDR *) &mysockaddr, sizeof(SOCKADDR_IN)) - == SOCKET_ERROR) { - goto error; + /* + * Populater the err Variable with a possix error + */ + optlen = sizeof(int); + ret = getsockopt(sock, SOL_SOCKET, SO_ERROR, + (char *)&err, &optlen); + /* + * The error was not returned directly but should be + * taken from WSA + */ + if (ret == SOCKET_ERROR) { + err = WSAGetLastError(); + } + /* + * Return error message + */ + if (err) { + TclWinConvertError(err); + Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(Tcl_GetErrno()), -1); + } } } + return TCL_OK; + } - /* - * Allocate socket info structure - */ - - infoPtr = NewSocketInfo(sock); - - /* - * Set the socket into nonblocking mode if the connect should be done - * in the background. Activate connect notification. - */ - - if (async) { + if ((len > 1) && (optionName[1] == 'c') && + (strncmp(optionName, "-connecting", len) == 0)) { - /* get infoPtr lock */ - WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + Tcl_DStringAppend(dsPtr, + (statePtr->flags & TCP_ASYNC_PENDING) + ? "1" : "0", -1); + return TCL_OK; + } - /* - * Buffer new infoPtr in the tsd memory as long as it is not in - * the info list. This allows the event procedure to process the - * event. - * Bugfig for 336441ed59 to not ignore notifications until the - * infoPtr is in the list.. - */ + if (interp != NULL && Tcl_GetVar(interp, SUPPRESS_RDNS_VAR, 0) != NULL) { + reverseDNS = NI_NUMERICHOST; + } - tsdPtr->pendingSocketInfo = infoPtr; + if ((len == 0) || ((len > 1) && (optionName[1] == 'p') && + (strncmp(optionName, "-peername", len) == 0))) { + address peername; + socklen_t size = sizeof(peername); + if ( (statePtr->flags & TCP_ASYNC_PENDING) ) { /* - * Set connect mask to connect events - * This is activated by a SOCKET_SELECT message to the notifier - * thread. + * In async connect output an empty string */ - - infoPtr->selectEvents |= FD_CONNECT | FD_READ | FD_WRITE | FD_CLOSE; - infoPtr->flags |= SOCKET_ASYNC_CONNECT; - + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-peername"); + Tcl_DStringAppendElement(dsPtr, ""); + } else { + return TCL_OK; + } + } else if ( getpeername(sock, (LPSOCKADDR) &(peername.sa), &size) == 0) { /* - * Free list lock + * Peername fetch succeeded - output list */ - SetEvent(tsdPtr->socketListLock); + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-peername"); + Tcl_DStringStartSublist(dsPtr); + } + getnameinfo(&(peername.sa), size, host, sizeof(host), + NULL, 0, NI_NUMERICHOST); + Tcl_DStringAppendElement(dsPtr, host); + getnameinfo(&(peername.sa), size, host, sizeof(host), + port, sizeof(port), reverseDNS | NI_NUMERICSERV); + Tcl_DStringAppendElement(dsPtr, host); + Tcl_DStringAppendElement(dsPtr, port); + if (len == 0) { + Tcl_DStringEndSublist(dsPtr); + } else { + return TCL_OK; + } + } else { /* - * Activate accept notification and put in async mode - * Bug 336441ed59: activate notification before connect - * so we do not miss a notification of a fialed connect. + * getpeername failed - but if we were asked for all the options + * (len==0), don't flag an error at that point because it could be + * an fconfigure request on a server socket (such sockets have no + * peer). {Copied from unix/tclUnixChan.c} */ - ioctlsocket(sock, (long) FIONBIO, &flag); - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, - (LPARAM) infoPtr); + if (len) { + TclWinConvertError((DWORD) WSAGetLastError()); + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get peername: %s", + Tcl_PosixError(interp))); + } + return TCL_ERROR; + } } + } - /* - * Attempt to connect to the remote socket. - */ - - if (connect(sock, (SOCKADDR *) &sockaddr, - sizeof(SOCKADDR_IN)) == SOCKET_ERROR) { - TclWinConvertWSAError((DWORD) WSAGetLastError()); - if (Tcl_GetErrno() != EWOULDBLOCK) { - goto error; - } + if ((len == 0) || ((len > 1) && (optionName[1] == 's') && + (strncmp(optionName, "-sockname", len) == 0))) { + TcpFdList *fds; + address sockname; + socklen_t size; + int found = 0; + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-sockname"); + Tcl_DStringStartSublist(dsPtr); + } + if ( (statePtr->flags & TCP_ASYNC_PENDING ) ) { /* - * The connection is progressing in the background. + * In async connect output an empty string */ - + found = 1; } else { + for (fds = statePtr->sockets; fds != NULL; fds = fds->next) { + sock = fds->fd; + size = sizeof(sockname); + if (getsockname(sock, &(sockname.sa), &size) >= 0) { + int flags = reverseDNS; - /* - * Set up the select mask for read/write events. If the connect - * attempt has not completed, include connect events. - */ + found = 1; + getnameinfo(&sockname.sa, size, host, sizeof(host), + NULL, 0, NI_NUMERICHOST); + Tcl_DStringAppendElement(dsPtr, host); - infoPtr->selectEvents = FD_READ | FD_WRITE | FD_CLOSE; + /* + * We don't want to resolve INADDR_ANY and sin6addr_any; they + * can sometimes cause problems (and never have a name). + */ + flags |= NI_NUMERICSERV; + if (sockname.sa.sa_family == AF_INET) { + if (sockname.sa4.sin_addr.s_addr == INADDR_ANY) { + flags |= NI_NUMERICHOST; + } + } else if (sockname.sa.sa_family == AF_INET6) { + if ((IN6_ARE_ADDR_EQUAL(&sockname.sa6.sin6_addr, + &in6addr_any)) || + (IN6_IS_ADDR_V4MAPPED(&sockname.sa6.sin6_addr) + && sockname.sa6.sin6_addr.s6_addr[12] == 0 + && sockname.sa6.sin6_addr.s6_addr[13] == 0 + && sockname.sa6.sin6_addr.s6_addr[14] == 0 + && sockname.sa6.sin6_addr.s6_addr[15] == 0)) { + flags |= NI_NUMERICHOST; + } + } + getnameinfo(&sockname.sa, size, host, sizeof(host), + port, sizeof(port), flags); + Tcl_DStringAppendElement(dsPtr, host); + Tcl_DStringAppendElement(dsPtr, port); + } + } + } + if (found) { + if (len) { + return TCL_OK; + } + Tcl_DStringEndSublist(dsPtr); + } else { + if (interp) { + TclWinConvertError((DWORD) WSAGetLastError()); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get sockname: %s", Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + } - /* - * Register for interest in events in the select mask. Note that this - * automatically places the socket into non-blocking mode. - */ +#ifdef TCL_FEATURE_KEEPALIVE_NAGLE + if (len == 0 || !strncmp(optionName, "-keepalive", len)) { + int optlen; + BOOL opt = FALSE; - ioctlsocket(sock, (long) FIONBIO, &flag); - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, - (LPARAM) infoPtr); + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-keepalive"); + } + optlen = sizeof(BOOL); + getsockopt(sock, SOL_SOCKET, SO_KEEPALIVE, (char *)&opt, &optlen); + if (opt) { + Tcl_DStringAppendElement(dsPtr, "1"); + } else { + Tcl_DStringAppendElement(dsPtr, "0"); + } + if (len > 0) { + return TCL_OK; } } - return infoPtr; + if (len == 0 || !strncmp(optionName, "-nagle", len)) { + int optlen; + BOOL opt = FALSE; - error: - TclWinConvertWSAError((DWORD) WSAGetLastError()); - if (interp != NULL) { - Tcl_AppendResult(interp, "couldn't open socket: ", - Tcl_PosixError(interp), NULL); + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-nagle"); + } + optlen = sizeof(BOOL); + getsockopt(sock, IPPROTO_TCP, TCP_NODELAY, (char *)&opt, &optlen); + if (opt) { + Tcl_DStringAppendElement(dsPtr, "0"); + } else { + Tcl_DStringAppendElement(dsPtr, "1"); + } + if (len > 0) { + return TCL_OK; + } } - if (infoPtr != NULL) { - /* - * Free the allocated socket info structure and close the socket - */ - TcpCloseProc(infoPtr, interp); - } else if (sock != INVALID_SOCKET) { - /* - * No socket structure jet - just close - */ - closesocket(sock); +#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/ + + if (len > 0) { +#ifdef TCL_FEATURE_KEEPALIVE_NAGLE + return Tcl_BadChannelOption(interp, optionName, + "connecting peername sockname keepalive nagle"); +#else + return Tcl_BadChannelOption(interp, optionName, "connecting peername sockname"); +#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/ } - return NULL; + + return TCL_OK; } /* *---------------------------------------------------------------------- * - * CreateSocketAddress -- + * TcpWatchProc -- * - * This function initializes a sockaddr structure for a host and port. + * Informs the channel driver of the events that the generic channel code + * wishes to receive on this socket. * * Results: - * 1 if the host was valid, 0 if the host could not be converted to an IP - * address. + * None. * * Side effects: - * Fills in the *sockaddrPtr structure. + * May cause the notifier to poll if any of the specified conditions are + * already true. * *---------------------------------------------------------------------- */ -static int -CreateSocketAddress( - LPSOCKADDR_IN sockaddrPtr, /* Socket address */ - const char *host, /* Host. NULL implies INADDR_ANY */ - int port) /* Port number */ +static void +TcpWatchProc( + ClientData instanceData, /* The socket state. */ + int mask) /* Events of interest; an OR-ed combination of + * TCL_READABLE, TCL_WRITABLE and + * TCL_EXCEPTION. */ { - struct hostent *hostent; /* Host database entry */ - struct in_addr addr; /* For 64/32 bit madness */ + TcpState *statePtr = instanceData; /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. + * Update the watch events mask. Only if the socket is not a server + * socket. [Bug 557878] */ - if (!SocketsEnabled()) { - Tcl_SetErrno(EFAULT); - return 0; - } + if (!statePtr->acceptProc) { + statePtr->watchEvents = 0; + if (mask & TCL_READABLE) { + statePtr->watchEvents |= (FD_READ|FD_CLOSE); + } + if (mask & TCL_WRITABLE) { + statePtr->watchEvents |= (FD_WRITE|FD_CLOSE); + } - ZeroMemory(sockaddrPtr, sizeof(SOCKADDR_IN)); - sockaddrPtr->sin_family = AF_INET; - sockaddrPtr->sin_port = htons((unsigned short) (port & 0xFFFF)); - if (host == NULL) { - addr.s_addr = INADDR_ANY; - } else { - addr.s_addr = inet_addr(host); - if (addr.s_addr == INADDR_NONE) { - hostent = gethostbyname(host); - if (hostent != NULL) { - memcpy(&addr, hostent->h_addr, (size_t) hostent->h_length); - } else { -#ifdef EHOSTUNREACH - Tcl_SetErrno(EHOSTUNREACH); -#else -#ifdef ENXIO - Tcl_SetErrno(ENXIO); -#endif -#endif - return 0; /* Error. */ - } + /* + * If there are any conditions already set, then tell the notifier to + * poll rather than block. + */ + + if (statePtr->readyEvents & statePtr->watchEvents) { + Tcl_Time blockTime = { 0, 0 }; + + Tcl_SetMaxBlockTime(&blockTime); } } +} + +/* + *---------------------------------------------------------------------- + * + * TcpGetHandleProc -- + * + * Called from Tcl_GetChannelHandle to retrieve OS handles from inside a + * TCP socket based channel. + * + * Results: + * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if there is no + * handle for the specified direction. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - /* - * NOTE: On 64 bit machines the assignment below is rumored to not do the - * right thing. Please report errors related to this if you observe - * incorrect behavior on 64 bit machines such as DEC Alphas. Should we - * modify this code to do an explicit memcpy? - */ + /* ARGSUSED */ +static int +TcpGetHandleProc( + ClientData instanceData, /* The socket state. */ + int direction, /* Not used. */ + ClientData *handlePtr) /* Where to store the handle. */ +{ + TcpState *statePtr = instanceData; - sockaddrPtr->sin_addr.s_addr = addr.s_addr; - return 1; /* Success. */ + *handlePtr = INT2PTR(statePtr->sockets->fd); + return TCL_OK; } + + /* *---------------------------------------------------------------------- * - * WaitForSocketEvent -- + * TcpConnect -- * - * Waits until one of the specified events occurs on a socket. + * This function opens a new socket in client mode. + * + * This might be called in 3 circumstances: + * - By a regular socket command + * - By the event handler to continue an asynchronously connect + * - By a blocking socket function (gets/puts) to terminate the + * connect synchronously * * Results: - * Returns 1 on success or 0 on failure, with an error code in - * errorCodePtr. + * TCL_OK, if the socket was successfully connected or an asynchronous + * connection is in progress. If an error occurs, TCL_ERROR is returned + * and an error message is left in interp. * * Side effects: - * Processes socket events off the system queue. + * Opens a socket. + * + * Remarks: + * A single host name may resolve to more than one IP address, e.g. for + * an IPv4/IPv6 dual stack host. For handling asynchronously 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 synchronously connecting sockets, the loops work the usual way. * *---------------------------------------------------------------------- */ static int -WaitForSocketEvent( - SocketInfo *infoPtr, /* Information about this socket. */ - int events, /* Events to look for. */ - int *errorCodePtr) /* Where to store errors? */ +TcpConnect( + Tcl_Interp *interp, /* For error reporting; can be NULL. */ + TcpState *statePtr) { - int result = 1; - int oldMode; - ThreadSpecificData *tsdPtr = (ThreadSpecificData *) - TclThreadDataKeyGet(&dataKey); - + DWORD error; /* - * Be sure to disable event servicing so we are truly modal. + * We are started with async connect and the connect notification + * was not jet received */ + int async_connect = statePtr->flags & TCP_ASYNC_CONNECT; + /* We were called by the event procedure and continue our loop */ + int async_callback = statePtr->flags & TCP_ASYNC_PENDING; + ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); - oldMode = Tcl_SetServiceMode(TCL_SERVICE_NONE); + if (async_callback) { + goto reenter; + } + + for (statePtr->addr = statePtr->addrlist; statePtr->addr != NULL; + statePtr->addr = statePtr->addr->ai_next) { + + for (statePtr->myaddr = statePtr->myaddrlist; statePtr->myaddr != NULL; + statePtr->myaddr = statePtr->myaddr->ai_next) { + + /* + * No need to try combinations of local and remote addresses + * of different families. + */ + + if (statePtr->myaddr->ai_family != statePtr->addr->ai_family) { + continue; + } + + /* + * Close the socket if it is still open from the last unsuccessful + * iteration. + */ + if (statePtr->sockets->fd != INVALID_SOCKET) { + closesocket(statePtr->sockets->fd); + } + + /* get statePtr lock */ + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + + /* + * Reset last error from last try + */ + statePtr->notifierConnectError = 0; + Tcl_SetErrno(0); + + statePtr->sockets->fd = socket(statePtr->myaddr->ai_family, SOCK_STREAM, 0); + + /* Free list lock */ + SetEvent(tsdPtr->socketListLock); + + /* continue on socket creation error */ + if (statePtr->sockets->fd == INVALID_SOCKET) { + TclWinConvertError((DWORD) WSAGetLastError()); + continue; + } + + /* + * Win-NT has a misfeature that sockets are inherited in child + * processes by default. Turn off the inherit bit. + */ + + SetHandleInformation((HANDLE) statePtr->sockets->fd, HANDLE_FLAG_INHERIT, 0); + + /* + * Set kernel space buffering + */ + + TclSockMinimumBuffers((void *) statePtr->sockets->fd, TCP_BUFFER_SIZE); + + /* + * Try to bind to a local port. + */ + + if (bind(statePtr->sockets->fd, statePtr->myaddr->ai_addr, + statePtr->myaddr->ai_addrlen) == SOCKET_ERROR) { + TclWinConvertError((DWORD) WSAGetLastError()); + continue; + } + /* + * For asynchroneous 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 asynchroneously + */ + tsdPtr->pendingTcpState = NULL; + if (Tcl_GetErrno() == 0) { + goto out; + } + } + } + +out: /* - * Reset WSAAsyncSelect so we have a fresh set of events pending. - * Don't do that if we are waiting for a connect as we may miss - * a connect (bug 336441ed59). + * Socket connected or connection failed */ - if ( 0 == (events & FD_CONNECT) ) { - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT, - (LPARAM) infoPtr); - - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, - (LPARAM) infoPtr); - } + /* + * Async connect terminated + */ - while (1) { - if (infoPtr->lastError) { - *errorCodePtr = infoPtr->lastError; - result = 0; - break; - } else if (infoPtr->readyEvents & events) { - break; - } else if (infoPtr->flags & SOCKET_ASYNC) { - *errorCodePtr = EWOULDBLOCK; - result = 0; - break; - } + CLEAR_BITS(statePtr->flags, TCP_ASYNC_CONNECT); + if ( Tcl_GetErrno() == 0 ) { /* - * Wait until something happens. + * Succesfully connected + */ + /* + * Set up the select mask for read/write events. */ + statePtr->selectEvents = FD_READ | FD_WRITE | FD_CLOSE; - WaitForSingleObject(tsdPtr->readyEvent, INFINITE); - } + /* + * Register for interest in events in the select mask. Note that this + * automatically places the socket into non-blocking mode. + */ - (void) Tcl_SetServiceMode(oldMode); - return result; + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, + (LPARAM) statePtr); + } else { + /* + * Connect failed + */ + + /* + * For async connect schedule a writable event to report the fail. + */ + if (async_callback) { + /* + * Set up the select mask for read/write events. + */ + statePtr->selectEvents = FD_WRITE|FD_READ; + /* get statePtr lock */ + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + /* Signal ready readable and writable events */ + statePtr->readyEvents |= FD_WRITE | FD_READ; + /* Flag error to event routine */ + statePtr->flags |= TCP_ASYNC_FAILED; + /* Save connect error to be reported by 'fconfigure -error' */ + statePtr->connectError = Tcl_GetErrno(); + /* Free list lock */ + SetEvent(tsdPtr->socketListLock); + } + /* + * Error message on synchroneous connect + */ + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open socket: %s", Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + return TCL_OK; } /* @@ -1299,40 +1903,75 @@ Tcl_OpenTcpClient( const char *host, /* Host on which to open port. */ const char *myaddr, /* Client-side address */ int myport, /* Client-side port */ - int async) /* If nonzero, should connect client socket - * asynchronously. */ + int async) /* If nonzero, attempt to do an asynchronous + * connect. Otherwise we do a blocking + * connect. */ { - SocketInfo *infoPtr; - char channelName[16 + TCL_INTEGER_SPACE]; + TcpState *statePtr; + const char *errorMsg = NULL; + struct addrinfo *addrlist = NULL, *myaddrlist = NULL; + char channelName[SOCK_CHAN_LENGTH]; if (TclpHasSockets(interp) != TCL_OK) { return NULL; } /* - * Create a new client socket and wrap it in a channel. + * Check that WinSock is initialized; do not call it if not, to prevent + * system crashes. This can happen at exit time if the exit handler for + * WinSock ran before other exit handlers that want to use sockets. */ - infoPtr = CreateSocket(interp, port, host, 0, myaddr, myport, async); - if (infoPtr == NULL) { + if (!SocketsEnabled()) { return NULL; } - sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t)infoPtr->socket); + /* + * Do the name lookups for the local and remote addresses. + */ - infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, - (ClientData) infoPtr, (TCL_READABLE | TCL_WRITABLE)); - if (Tcl_SetChannelOption(interp, infoPtr->channel, "-translation", - "auto crlf") == TCL_ERROR) { - Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel); - return (Tcl_Channel) NULL; + if (!TclCreateSocketAddress(interp, &addrlist, host, port, 0, &errorMsg) + || !TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1, + &errorMsg)) { + if (addrlist != NULL) { + freeaddrinfo(addrlist); + } + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open socket: %s", errorMsg)); + } + return NULL; } - if (Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "") - == TCL_ERROR) { - Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel); - return (Tcl_Channel) NULL; + + statePtr = NewSocketInfo(INVALID_SOCKET); + statePtr->addrlist = addrlist; + statePtr->myaddrlist = myaddrlist; + if (async) { + statePtr->flags |= TCP_ASYNC_CONNECT; + } + + /* + * Create a new client socket and wrap it in a channel. + */ + if (TcpConnect(interp, statePtr) != TCL_OK) { + TcpCloseProc(statePtr, NULL); + return NULL; + } + + sprintf(channelName, SOCK_TEMPLATE, statePtr); + + statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, + statePtr, (TCL_READABLE | TCL_WRITABLE)); + if (TCL_ERROR == Tcl_SetChannelOption(NULL, statePtr->channel, + "-translation", "auto crlf")) { + Tcl_Close(NULL, statePtr->channel); + return NULL; + } else if (TCL_ERROR == Tcl_SetChannelOption(NULL, statePtr->channel, + "-eofchar", "")) { + Tcl_Close(NULL, statePtr->channel); + return NULL; } - return infoPtr->channel; + return statePtr->channel; } /* @@ -1348,8 +1987,6 @@ Tcl_OpenTcpClient( * Side effects: * None. * - * NOTE: Code contributed by Mark Diekhans (markd@grizzly.com) - * *---------------------------------------------------------------------- */ @@ -1357,15 +1994,15 @@ Tcl_Channel Tcl_MakeTcpClientChannel( ClientData sock) /* The socket to wrap up into a channel. */ { - SocketInfo *infoPtr; - char channelName[16 + TCL_INTEGER_SPACE]; + TcpState *statePtr; + char channelName[SOCK_CHAN_LENGTH]; ThreadSpecificData *tsdPtr; if (TclpHasSockets(NULL) != TCL_OK) { return NULL; } - tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); + tsdPtr = TclThreadDataKeyGet(&dataKey); /* * Set kernel space buffering and non-blocking. @@ -1373,21 +2010,20 @@ Tcl_MakeTcpClientChannel( TclSockMinimumBuffers(sock, TCP_BUFFER_SIZE); - infoPtr = NewSocketInfo((SOCKET) sock); + statePtr = NewSocketInfo((SOCKET) sock); /* * Start watching for read/write events on the socket. */ - infoPtr->selectEvents = FD_READ | FD_CLOSE | FD_WRITE; - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) SELECT, (LPARAM) infoPtr); + statePtr->selectEvents = FD_READ | FD_CLOSE | FD_WRITE; + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)statePtr); - sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t)infoPtr->socket); - infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, - (ClientData) infoPtr, (TCL_READABLE | TCL_WRITABLE)); - Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto crlf"); - return infoPtr->channel; + sprintf(channelName, SOCK_TEMPLATE, statePtr); + statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, + statePtr, (TCL_READABLE | TCL_WRITABLE)); + Tcl_SetChannelOption(NULL, statePtr->channel, "-translation", "auto crlf"); + return statePtr->channel; } /* @@ -1398,8 +2034,8 @@ Tcl_MakeTcpClientChannel( * Opens a TCP server socket and creates a channel around it. * * Results: - * The channel or NULL if failed. An error message is returned in the - * interpreter on failure. + * The channel or NULL if failed. If an error occurred, an error message + * is left in the interp's result if interp is not NULL. * * Side effects: * Opens a server socket and creates a new channel. @@ -1411,115 +2047,205 @@ Tcl_Channel Tcl_OpenTcpServer( Tcl_Interp *interp, /* For error reporting - may be NULL. */ int port, /* Port number to open. */ - const char *host, /* Name of local host. */ + const char *myHost, /* Name of local host. */ Tcl_TcpAcceptProc *acceptProc, /* Callback for accepting connections from new * clients. */ ClientData acceptProcData) /* Data for the callback. */ { - SocketInfo *infoPtr; - char channelName[16 + TCL_INTEGER_SPACE]; + SOCKET sock = INVALID_SOCKET; + unsigned short chosenport = 0; + struct addrinfo *addrlist = NULL; + struct addrinfo *addrPtr; /* Socket address to listen on. */ + TcpState *statePtr = NULL; /* The returned value. */ + char channelName[SOCK_CHAN_LENGTH]; + u_long flag = 1; /* Indicates nonblocking mode. */ + const char *errorMsg = NULL; if (TclpHasSockets(interp) != TCL_OK) { return NULL; } /* - * Create a new client socket and wrap it in a channel. + * Check that WinSock is initialized; do not call it if not, to prevent + * system crashes. This can happen at exit time if the exit handler for + * WinSock ran before other exit handlers that want to use sockets. */ - infoPtr = CreateSocket(interp, port, host, 1, NULL, 0, 0); - if (infoPtr == NULL) { + if (!SocketsEnabled()) { return NULL; } - infoPtr->acceptProc = acceptProc; - infoPtr->acceptProcData = acceptProcData; + /* + * Construct the addresses for each end of the socket. + */ + + if (!TclCreateSocketAddress(interp, &addrlist, myHost, port, 1, &errorMsg)) { + goto error; + } + + for (addrPtr = addrlist; addrPtr != NULL; addrPtr = addrPtr->ai_next) { + sock = socket(addrPtr->ai_family, addrPtr->ai_socktype, + addrPtr->ai_protocol); + if (sock == INVALID_SOCKET) { + TclWinConvertError((DWORD) WSAGetLastError()); + continue; + } + + /* + * Win-NT has a misfeature that sockets are inherited in child + * processes by default. Turn off the inherit bit. + */ + + SetHandleInformation((HANDLE) sock, HANDLE_FLAG_INHERIT, 0); + + /* + * Set kernel space buffering + */ + + TclSockMinimumBuffers((void *)sock, TCP_BUFFER_SIZE); + + /* + * Make sure we use the same port when opening two server sockets + * for IPv4 and IPv6. + * + * As sockaddr_in6 uses the same offset and size for the port + * member as sockaddr_in, we can handle both through the IPv4 API. + */ + + if (port == 0 && chosenport != 0) { + ((struct sockaddr_in *) addrPtr->ai_addr)->sin_port = + htons(chosenport); + } + + /* + * Bind to the specified port. Note that we must not call + * setsockopt with SO_REUSEADDR because Microsoft allows addresses + * to be reused even if they are still in use. + * + * Bind should not be affected by the socket having already been + * set into nonblocking mode. If there is trouble, this is one + * place to look for bugs. + */ + + if (bind(sock, addrPtr->ai_addr, addrPtr->ai_addrlen) + == SOCKET_ERROR) { + TclWinConvertError((DWORD) WSAGetLastError()); + closesocket(sock); + continue; + } + if (port == 0 && chosenport == 0) { + address sockname; + socklen_t namelen = sizeof(sockname); + + /* + * Synchronize port numbers when binding to port 0 of multiple + * addresses. + */ + + if (getsockname(sock, &sockname.sa, &namelen) >= 0) { + chosenport = ntohs(sockname.sa4.sin_port); + } + } + + /* + * Set the maximum number of pending connect requests to the max + * value allowed on each platform (Win32 and Win32s may be + * different, and there may be differences between TCP/IP stacks). + */ + + if (listen(sock, SOMAXCONN) == SOCKET_ERROR) { + TclWinConvertError((DWORD) WSAGetLastError()); + closesocket(sock); + continue; + } + + if (statePtr == NULL) { + /* + * Add this socket to the global list of sockets. + */ + statePtr = NewSocketInfo(sock); + } else { + AddSocketInfoFd( statePtr, sock ); + } + } + +error: + if (addrlist != NULL) { + freeaddrinfo(addrlist); + } + + if (statePtr != NULL) { + ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + + statePtr->acceptProc = acceptProc; + statePtr->acceptProcData = acceptProcData; + sprintf(channelName, SOCK_TEMPLATE, statePtr); + statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, + statePtr, 0); + /* + * Set up the select mask for connection request events. + */ - sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t)infoPtr->socket); + statePtr->selectEvents = FD_ACCEPT; - infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, - (ClientData) infoPtr, 0); - if (Tcl_SetChannelOption(interp, infoPtr->channel, "-eofchar", "") + /* + * Register for interest in events in the select mask. Note that this + * automatically places the socket into non-blocking mode. + */ + + ioctlsocket(sock, (long) FIONBIO, &flag); + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, + (LPARAM) statePtr); + if (Tcl_SetChannelOption(interp, statePtr->channel, "-eofchar", "") == TCL_ERROR) { - Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel); - return (Tcl_Channel) NULL; + Tcl_Close(NULL, statePtr->channel); + return NULL; + } + return statePtr->channel; + } + + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open socket: %s", + (errorMsg ? errorMsg : Tcl_PosixError(interp)))); } - return infoPtr->channel; + if (sock != INVALID_SOCKET) { + closesocket(sock); + } + return NULL; } /* *---------------------------------------------------------------------- * * TcpAccept -- - * - * Accept a TCP socket connection. This is called by SocketEventProc and - * it in turns calls the registered accept function. + * Accept a TCP socket connection. This is called by the event loop. * * Results: * None. * * Side effects: - * Invokes the accept proc which may invoke arbitrary Tcl code. + * Creates a new connection socket. Calls the registered callback for the + * connection acceptance mechanism. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ static void TcpAccept( - SocketInfo *infoPtr) /* Socket to accept. */ + TcpFdList *fds, /* Server socket that accepted newSocket. */ + SOCKET newSocket, /* Newly accepted socket. */ + address addr) /* Address of new socket. */ { - SOCKET newSocket; - SocketInfo *newInfoPtr; - SOCKADDR_IN addr; - int len; - char channelName[16 + TCL_INTEGER_SPACE]; - ThreadSpecificData *tsdPtr = (ThreadSpecificData *) - TclThreadDataKeyGet(&dataKey); - - /* - * Accept the incoming connection request. - */ - - len = sizeof(SOCKADDR_IN); - - newSocket = accept(infoPtr->socket, (SOCKADDR *)&addr, - &len); - - /* - * Protect access to sockets (acceptEventCount, readyEvents) in socketList - * by the lock. Fix for SF Tcl Bug 3056775. - */ - WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - - /* - * Clear the ready mask so we can detect the next connection request. Note - * that connection requests are level triggered, so if there is a request - * already pending, a new event will be generated. - */ - - if (newSocket == INVALID_SOCKET) { - infoPtr->acceptEventCount = 0; - infoPtr->readyEvents &= ~(FD_ACCEPT); - - SetEvent(tsdPtr->socketListLock); - return; - } - - /* - * It is possible that more than one FD_ACCEPT has been sent, so an extra - * count must be kept. Decrement the count, and reset the readyEvent bit - * if the count is no longer > 0. - */ - - infoPtr->acceptEventCount--; - - if (infoPtr->acceptEventCount <= 0) { - infoPtr->readyEvents &= ~(FD_ACCEPT); - } - - SetEvent(tsdPtr->socketListLock); + TcpState *newInfoPtr; + TcpState *statePtr = fds->statePtr; + int len = sizeof(addr); + char channelName[SOCK_CHAN_LENGTH]; + char host[NI_MAXHOST], port[NI_MAXSERV]; + ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); /* * Win-NT has a misfeature that sockets are inherited in child processes @@ -1529,7 +2255,7 @@ TcpAccept( SetHandleInformation((HANDLE) newSocket, HANDLE_FLAG_INHERIT, 0); /* - * Allocate socket info structure + * Add this socket to the global list of sockets. */ newInfoPtr = NewSocketInfo(newSocket); @@ -1539,20 +2265,20 @@ TcpAccept( */ newInfoPtr->selectEvents = (FD_READ | FD_WRITE | FD_CLOSE); - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) SELECT, (LPARAM) newInfoPtr); + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, + (LPARAM) newInfoPtr); - sprintf(channelName, "sock%" TCL_I_MODIFIER "u", (size_t)newInfoPtr->socket); + sprintf(channelName, SOCK_TEMPLATE, newInfoPtr); newInfoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, - (ClientData) newInfoPtr, (TCL_READABLE | TCL_WRITABLE)); + newInfoPtr, (TCL_READABLE | TCL_WRITABLE)); if (Tcl_SetChannelOption(NULL, newInfoPtr->channel, "-translation", "auto crlf") == TCL_ERROR) { - Tcl_Close((Tcl_Interp *) NULL, newInfoPtr->channel); + Tcl_Close(NULL, newInfoPtr->channel); return; } if (Tcl_SetChannelOption(NULL, newInfoPtr->channel, "-eofchar", "") == TCL_ERROR) { - Tcl_Close((Tcl_Interp *) NULL, newInfoPtr->channel); + Tcl_Close(NULL, newInfoPtr->channel); return; } @@ -1560,647 +2286,683 @@ TcpAccept( * Invoke the accept callback function. */ - if (infoPtr->acceptProc != NULL) { - (infoPtr->acceptProc) (infoPtr->acceptProcData, newInfoPtr->channel, - inet_ntoa(addr.sin_addr), ntohs(addr.sin_port)); + if (statePtr->acceptProc != NULL) { + getnameinfo(&(addr.sa), len, host, sizeof(host), port, sizeof(port), + NI_NUMERICHOST|NI_NUMERICSERV); + statePtr->acceptProc(statePtr->acceptProcData, newInfoPtr->channel, + host, atoi(port)); } } /* *---------------------------------------------------------------------- * - * TcpInputProc -- + * InitSockets -- * - * This function is called by the generic IO level to read data from a - * socket based channel. + * Registers the event window for the socket notifier code. + * + * Assumes socketMutex is held. * * Results: - * The number of bytes read or -1 on error. + * None. * * Side effects: - * Consumes input from the socket. + * Register a new window class and creates a + * window for use in asynchronous socket notification. * *---------------------------------------------------------------------- */ -static int -TcpInputProc( - ClientData instanceData, /* The socket state. */ - char *buf, /* Where to store data. */ - int toRead, /* Maximum number of bytes to read. */ - int *errorCodePtr) /* Where to store error codes. */ +static void +InitSockets(void) { - SocketInfo *infoPtr = (SocketInfo *) instanceData; - int bytesRead; - DWORD error; - ThreadSpecificData *tsdPtr = (ThreadSpecificData *) - TclThreadDataKeyGet(&dataKey); + DWORD id; + ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); - *errorCodePtr = 0; + if (!initialized) { + initialized = 1; + TclCreateLateExitHandler(SocketExitHandler, NULL); - /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ + /* + * Create the async notification window with a new class. We must + * create a new class to avoid a Windows 95 bug that causes us to get + * the wrong message number for socket events if the message window is + * a subclass of a static control. + */ - if (!SocketsEnabled()) { - *errorCodePtr = EFAULT; - return -1; + windowClass.style = 0; + windowClass.cbClsExtra = 0; + windowClass.cbWndExtra = 0; + windowClass.hInstance = TclWinGetTclInstance(); + windowClass.hbrBackground = NULL; + windowClass.lpszMenuName = NULL; + windowClass.lpszClassName = classname; + windowClass.lpfnWndProc = SocketProc; + windowClass.hIcon = NULL; + windowClass.hCursor = NULL; + + if (!RegisterClass(&windowClass)) { + TclWinConvertError(GetLastError()); + goto initFailure; + } } /* - * First check to see if EOF was already detected, to prevent calling the - * socket stack after the first time EOF is detected. + * Check for per-thread initialization. */ - if (infoPtr->flags & SOCKET_EOF) { - return 0; + if (tsdPtr != NULL) { + return; } /* - * Check to see if the socket is connected before trying to read. + * OK, this thread has never done anything with sockets before. Construct + * a worker thread to handle asynchronous events related to sockets + * assigned to _this_ thread. */ - if ((infoPtr->flags & SOCKET_ASYNC_CONNECT) - && !WaitForSocketEvent(infoPtr, FD_CONNECT, errorCodePtr)) { - return -1; + tsdPtr = TCL_TSD_INIT(&dataKey); + tsdPtr->pendingTcpState = NULL; + tsdPtr->socketList = NULL; + tsdPtr->hwnd = NULL; + tsdPtr->threadId = Tcl_GetCurrentThread(); + tsdPtr->readyEvent = CreateEvent(NULL, FALSE, FALSE, NULL); + if (tsdPtr->readyEvent == NULL) { + goto initFailure; + } + tsdPtr->socketListLock = CreateEvent(NULL, FALSE, TRUE, NULL); + if (tsdPtr->socketListLock == NULL) { + goto initFailure; } + tsdPtr->socketThread = CreateThread(NULL, 256, SocketThread, tsdPtr, 0, + &id); + if (tsdPtr->socketThread == NULL) { + goto initFailure; + } + + SetThreadPriority(tsdPtr->socketThread, THREAD_PRIORITY_HIGHEST); /* - * No EOF, and it is connected, so try to read more from the socket. Note - * that we clear the FD_READ bit because read events are level triggered - * so a new event will be generated if there is still data available to be - * read. We have to simulate blocking behavior here since we are always - * using non-blocking sockets. + * Wait for the thread to signal when the window has been created and if + * it is ready to go. */ - while (1) { - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) UNSELECT, (LPARAM) infoPtr); - bytesRead = recv(infoPtr->socket, buf, toRead, 0); - infoPtr->readyEvents &= ~(FD_READ); + WaitForSingleObject(tsdPtr->readyEvent, INFINITE); - /* - * Check for end-of-file condition or successful read. - */ - - if (bytesRead == 0) { - infoPtr->flags |= SOCKET_EOF; - } - if (bytesRead != SOCKET_ERROR) { - break; - } - - /* - * If an error occurs after the FD_CLOSE has arrived, then ignore the - * error and report an EOF. - */ - - if (infoPtr->readyEvents & FD_CLOSE) { - infoPtr->flags |= SOCKET_EOF; - bytesRead = 0; - break; - } - - error = WSAGetLastError(); - - /* - * If an RST comes, then ignore the error and report an EOF just like - * on unix. - */ - - if (error == WSAECONNRESET) { - infoPtr->flags |= SOCKET_EOF; - bytesRead = 0; - break; - } - - /* - * Check for error condition or underflow in non-blocking case. - */ - - if ((infoPtr->flags & SOCKET_ASYNC) || (error != WSAEWOULDBLOCK)) { - TclWinConvertWSAError(error); - *errorCodePtr = Tcl_GetErrno(); - bytesRead = -1; - break; - } - - /* - * In the blocking case, wait until the file becomes readable or - * closed and try again. - */ - - if (!WaitForSocketEvent(infoPtr, FD_READ|FD_CLOSE, errorCodePtr)) { - bytesRead = -1; - break; - } + if (tsdPtr->hwnd == NULL) { + goto initFailure; /* Trouble creating the window. */ } - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) SELECT, (LPARAM) infoPtr); + Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL); + return; - return bytesRead; + initFailure: + TclpFinalizeSockets(); + initialized = -1; + return; } /* *---------------------------------------------------------------------- * - * TcpOutputProc -- + * SocketsEnabled -- * - * This function is called by the generic IO level to write data to a - * socket based channel. + * Check that the WinSock was successfully initialized. + * + * Warning: + * This check was useful in times of Windows98 where WinSock may + * not be available. This is not the case any more. + * This function may be removed with TCL 9.0 * * Results: - * The number of bytes written or -1 on failure. + * 1 if it is. * * Side effects: - * Produces output on the socket. + * None. * *---------------------------------------------------------------------- */ + /* ARGSUSED */ static int -TcpOutputProc( - ClientData instanceData, /* The socket state. */ - const char *buf, /* Where to get data. */ - int toWrite, /* Maximum number of bytes to write. */ - int *errorCodePtr) /* Where to store error codes. */ +SocketsEnabled(void) { - SocketInfo *infoPtr = (SocketInfo *) instanceData; - int bytesWritten; - DWORD error; - ThreadSpecificData *tsdPtr = (ThreadSpecificData *) - TclThreadDataKeyGet(&dataKey); + int enabled; - *errorCodePtr = 0; + Tcl_MutexLock(&socketMutex); + enabled = (initialized == 1); + Tcl_MutexUnlock(&socketMutex); + return enabled; +} - /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ + +/* + *---------------------------------------------------------------------- + * + * SocketExitHandler -- + * + * Callback invoked during exit clean up to delete the socket + * communication window. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ - if (!SocketsEnabled()) { - *errorCodePtr = EFAULT; - return -1; - } + /* ARGSUSED */ +static void +SocketExitHandler( + ClientData clientData) /* Not used. */ +{ + Tcl_MutexLock(&socketMutex); /* - * Check to see if the socket is connected before trying to write. + * Make sure the socket event handling window is cleaned-up for, at + * most, this thread. */ - if ((infoPtr->flags & SOCKET_ASYNC_CONNECT) - && !WaitForSocketEvent(infoPtr, FD_CONNECT, errorCodePtr)) { - return -1; - } - - while (1) { - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) UNSELECT, (LPARAM) infoPtr); - - bytesWritten = send(infoPtr->socket, buf, toWrite, 0); - if (bytesWritten != SOCKET_ERROR) { - /* - * Since Windows won't generate a new write event until we hit an - * overflow condition, we need to force the event loop to poll - * until the condition changes. - */ - - if (infoPtr->watchEvents & FD_WRITE) { - Tcl_Time blockTime = { 0, 0 }; - Tcl_SetMaxBlockTime(&blockTime); - } - break; - } - - /* - * Check for error condition or overflow. In the event of overflow, we - * need to clear the FD_WRITE flag so we can detect the next writable - * event. Note that Windows only sends a new writable event after a - * send fails with WSAEWOULDBLOCK. - */ + TclpFinalizeSockets(); + UnregisterClass(classname, TclWinGetTclInstance()); + initialized = 0; + Tcl_MutexUnlock(&socketMutex); +} + +/* + *---------------------------------------------------------------------- + * + * SocketSetupProc -- + * + * This function is invoked before Tcl_DoOneEvent blocks waiting for an + * event. + * + * Results: + * None. + * + * Side effects: + * Adjusts the block time if needed. + * + *---------------------------------------------------------------------- + */ - error = WSAGetLastError(); - if (error == WSAEWOULDBLOCK) { - infoPtr->readyEvents &= ~(FD_WRITE); - if (infoPtr->flags & SOCKET_ASYNC) { - *errorCodePtr = EWOULDBLOCK; - bytesWritten = -1; - break; - } - } else { - TclWinConvertWSAError(error); - *errorCodePtr = Tcl_GetErrno(); - bytesWritten = -1; - break; - } +void +SocketSetupProc( + ClientData data, /* Not used. */ + int flags) /* Event flags as passed to Tcl_DoOneEvent. */ +{ + TcpState *statePtr; + Tcl_Time blockTime = { 0, 0 }; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - /* - * In the blocking case, wait until the file becomes writable or - * closed and try again. - */ + if (!(flags & TCL_FILE_EVENTS)) { + return; + } - if (!WaitForSocketEvent(infoPtr, FD_WRITE|FD_CLOSE, errorCodePtr)) { - bytesWritten = -1; + /* + * Check to see if there is a ready socket. If so, poll. + */ + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + for (statePtr = tsdPtr->socketList; statePtr != NULL; + statePtr = statePtr->nextPtr) { + if (statePtr->readyEvents & + (statePtr->watchEvents | FD_CONNECT | FD_ACCEPT) + ) { + Tcl_SetMaxBlockTime(&blockTime); break; } } - - SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) SELECT, (LPARAM) infoPtr); - - return bytesWritten; + SetEvent(tsdPtr->socketListLock); } /* *---------------------------------------------------------------------- * - * TcpSetOptionProc -- + * SocketCheckProc -- * - * Sets Tcp channel specific options. + * This function is called by Tcl_DoOneEvent to check the socket event + * source for events. * * Results: - * None, unless an error happens. + * None. * * Side effects: - * Changes attributes of the socket at the system level. + * May queue an event. * *---------------------------------------------------------------------- */ -static int -TcpSetOptionProc( - ClientData instanceData, /* Socket state. */ - Tcl_Interp *interp, /* For error reporting - can be NULL. */ - const char *optionName, /* Name of the option to set. */ - const char *value) /* New value for option. */ +static void +SocketCheckProc( + ClientData data, /* Not used. */ + int flags) /* Event flags as passed to Tcl_DoOneEvent. */ { -#ifdef TCL_FEATURE_KEEPALIVE_NAGLE - SocketInfo *infoPtr; - SOCKET sock; -#endif - - /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. - */ + TcpState *statePtr; + SocketEvent *evPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - if (!SocketsEnabled()) { - if (interp) { - Tcl_AppendResult(interp, "winsock is not initialized", NULL); - } - return TCL_ERROR; + if (!(flags & TCL_FILE_EVENTS)) { + return; } -#ifdef TCL_FEATURE_KEEPALIVE_NAGLE - infoPtr = (SocketInfo *) instanceData; - sock = infoPtr->socket; - - if (!strcasecmp(optionName, "-keepalive")) { - BOOL val = FALSE; - int boolVar, rtn; - - if (Tcl_GetBoolean(interp, value, &boolVar) != TCL_OK) { - return TCL_ERROR; - } - if (boolVar) { - val = TRUE; - } - rtn = setsockopt(sock, SOL_SOCKET, SO_KEEPALIVE, - (const char *) &val, sizeof(BOOL)); - if (rtn != 0) { - TclWinConvertWSAError(WSAGetLastError()); - if (interp) { - Tcl_AppendResult(interp, "couldn't set socket option: ", - Tcl_PosixError(interp), NULL); - } - return TCL_ERROR; - } - return TCL_OK; - } else if (!strcasecmp(optionName, "-nagle")) { - BOOL val = FALSE; - int boolVar, rtn; + /* + * Queue events for any ready sockets that don't already have events + * queued (caused by persistent states that won't generate WinSock + * events). + */ - if (Tcl_GetBoolean(interp, value, &boolVar) != TCL_OK) { - return TCL_ERROR; - } - if (!boolVar) { - val = TRUE; - } - rtn = setsockopt(sock, IPPROTO_TCP, TCP_NODELAY, - (const char *) &val, sizeof(BOOL)); - if (rtn != 0) { - TclWinConvertWSAError(WSAGetLastError()); - if (interp) { - Tcl_AppendResult(interp, "couldn't set socket option: ", - Tcl_PosixError(interp), NULL); - } - return TCL_ERROR; + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + for (statePtr = tsdPtr->socketList; statePtr != NULL; + statePtr = statePtr->nextPtr) { + if ((statePtr->readyEvents & + (statePtr->watchEvents | FD_CONNECT | FD_ACCEPT)) + && !(statePtr->flags & SOCKET_PENDING) + ) { + statePtr->flags |= SOCKET_PENDING; + evPtr = ckalloc(sizeof(SocketEvent)); + evPtr->header.proc = SocketEventProc; + evPtr->socket = statePtr->sockets->fd; + Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); } - return TCL_OK; } - - return Tcl_BadChannelOption(interp, optionName, "keepalive nagle"); -#else - return Tcl_BadChannelOption(interp, optionName, ""); -#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/ + SetEvent(tsdPtr->socketListLock); } /* *---------------------------------------------------------------------- * - * TcpGetOptionProc -- - * - * Computes an option value for a TCP socket based channel, or a list of - * all options and their values. + * SocketEventProc -- * - * Note: This code is based on code contributed by John Haxby. + * This function is called by Tcl_ServiceEvent when a socket event + * reaches the front of the event queue. This function is responsible for + * notifying the generic channel code. * * Results: - * A standard Tcl result. The value of the specified option or a list of - * all options and their values is returned in the supplied DString. + * Returns 1 if the event was handled, meaning it should be removed from + * the queue. Returns 0 if the event was not handled, meaning it should + * stay on the queue. The only time the event isn't handled is if the + * TCL_FILE_EVENTS flag bit isn't set. * * Side effects: - * None. + * Whatever the channel callback functions do. * *---------------------------------------------------------------------- */ static int -TcpGetOptionProc( - ClientData instanceData, /* Socket state. */ - Tcl_Interp *interp, /* For error reporting - can be NULL */ - const char *optionName, /* Name of the option to retrieve the value - * for, or NULL to get all options and their - * values. */ - Tcl_DString *dsPtr) /* Where to store the computed value; - * initialized by caller. */ +SocketEventProc( + Tcl_Event *evPtr, /* Event to service. */ + int flags) /* Flags that indicate what events to handle, + * such as TCL_FILE_EVENTS. */ { - SocketInfo *infoPtr; - SOCKADDR_IN sockname; - SOCKADDR_IN peername; - struct hostent *hostEntPtr; - SOCKET sock; - int size = sizeof(SOCKADDR_IN); - size_t len = 0; - char buf[TCL_INTEGER_SPACE]; + TcpState *statePtr; + SocketEvent *eventPtr = (SocketEvent *) evPtr; + int mask = 0, events; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + TcpFdList *fds; + SOCKET newSocket; + address addr; + int len; + + if (!(flags & TCL_FILE_EVENTS)) { + return 0; + } /* - * Check that WinSock is initialized; do not call it if not, to prevent - * system crashes. This can happen at exit time if the exit handler for - * WinSock ran before other exit handlers that want to use sockets. + * Find the specified socket on the socket list. */ - if (!SocketsEnabled()) { - if (interp) { - Tcl_AppendResult(interp, "winsock is not initialized", NULL); + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + for (statePtr = tsdPtr->socketList; statePtr != NULL; + statePtr = statePtr->nextPtr) { + if (statePtr->sockets->fd == eventPtr->socket) { + break; } - return TCL_ERROR; } - infoPtr = (SocketInfo *) instanceData; - sock = (int) infoPtr->socket; - if (optionName != NULL) { - len = strlen(optionName); + /* + * Discard events that have gone stale. + */ + + if (!statePtr) { + SetEvent(tsdPtr->socketListLock); + return 1; } - if ((len > 1) && (optionName[1] == 'e') && - (strncmp(optionName, "-error", len) == 0)) { - int optlen; - DWORD err; - int ret; + /* + * Clear flag that (this) event is pending + */ - optlen = sizeof(int); - ret = TclWinGetSockOpt((int)sock, SOL_SOCKET, SO_ERROR, - (char *)&err, &optlen); - if (ret == SOCKET_ERROR) { - err = WSAGetLastError(); - } - if (err) { - TclWinConvertWSAError(err); - Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(Tcl_GetErrno()), -1); - } - return TCL_OK; - } + statePtr->flags &= ~SOCKET_PENDING; - if ((len == 0) || ((len > 1) && (optionName[1] == 'p') && - (strncmp(optionName, "-peername", len) == 0))) { - if (getpeername(sock, (LPSOCKADDR) &peername, &size) == 0) { - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-peername"); - Tcl_DStringStartSublist(dsPtr); - } - Tcl_DStringAppendElement(dsPtr, inet_ntoa(peername.sin_addr)); + /* + * Continue async connect if pending and ready + */ + + if ( statePtr->readyEvents & FD_CONNECT ) { + if ( statePtr->flags & TCP_ASYNC_PENDING ) { + + /* + * Do one step and save eventual connect error + */ + + SetEvent(tsdPtr->socketListLock); + WaitForConnect(statePtr,NULL); - if (peername.sin_addr.s_addr == 0) { - hostEntPtr = NULL; - } else { - hostEntPtr = gethostbyaddr((char *) &(peername.sin_addr), - sizeof(peername.sin_addr), AF_INET); - } - if (hostEntPtr != NULL) { - Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name); - } else { - Tcl_DStringAppendElement(dsPtr, inet_ntoa(peername.sin_addr)); - } - TclFormatInt(buf, ntohs(peername.sin_port)); - Tcl_DStringAppendElement(dsPtr, buf); - if (len == 0) { - Tcl_DStringEndSublist(dsPtr); - } else { - return TCL_OK; - } } else { + /* - * getpeername failed - but if we were asked for all the options - * (len==0), don't flag an error at that point because it could be - * an fconfigure request on a server socket (such sockets have no - * peer). {Copied from unix/tclUnixChan.c} + * No async connect reenter pending. Just clear event. */ - if (len) { - TclWinConvertWSAError((DWORD) WSAGetLastError()); - if (interp) { - Tcl_AppendResult(interp, "can't get peername: ", - Tcl_PosixError(interp), NULL); - } - return TCL_ERROR; - } + statePtr->readyEvents &= ~(FD_CONNECT); + SetEvent(tsdPtr->socketListLock); } + return 1; } - if ((len == 0) || ((len > 1) && (optionName[1] == 's') && - (strncmp(optionName, "-sockname", len) == 0))) { - if (getsockname(sock, (LPSOCKADDR) &sockname, &size) == 0) { - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-sockname"); - Tcl_DStringStartSublist(dsPtr); - } - Tcl_DStringAppendElement(dsPtr, inet_ntoa(sockname.sin_addr)); - if (sockname.sin_addr.s_addr == 0) { - hostEntPtr = NULL; - } else { - hostEntPtr = gethostbyaddr((char *) &(sockname.sin_addr), - sizeof(peername.sin_addr), AF_INET); - } - if (hostEntPtr != NULL) { - Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name); - } else { - Tcl_DStringAppendElement(dsPtr, inet_ntoa(sockname.sin_addr)); - } - TclFormatInt(buf, ntohs(sockname.sin_port)); - Tcl_DStringAppendElement(dsPtr, buf); - if (len == 0) { - Tcl_DStringEndSublist(dsPtr); - } else { - return TCL_OK; + /* + * Handle connection requests directly. + */ + if (statePtr->readyEvents & FD_ACCEPT) { + for (fds = statePtr->sockets; fds != NULL; fds = fds->next) { + + /* + * Accept the incoming connection request. + */ + len = sizeof(address); + + newSocket = accept(fds->fd, &(addr.sa), &len); + + /* On Tcl server sockets with multiple OS fds we loop over the fds trying + * an accept() on each, so we expect INVALID_SOCKET. There are also other + * network stack conditions that can result in FD_ACCEPT but a subsequent + * failure on accept() by the time we get around to it. + * Access to sockets (acceptEventCount, readyEvents) in socketList + * is still protected by the lock (prevents reintroduction of + * SF Tcl Bug 3056775. + */ + + if (newSocket == INVALID_SOCKET) { + /* int err = WSAGetLastError(); */ + continue; } - } else { - if (interp) { - TclWinConvertWSAError((DWORD) WSAGetLastError()); - Tcl_AppendResult(interp, "can't get sockname: ", - Tcl_PosixError(interp), NULL); + + /* + * It is possible that more than one FD_ACCEPT has been sent, so an extra + * count must be kept. Decrement the count, and reset the readyEvent bit + * if the count is no longer > 0. + */ + statePtr->acceptEventCount--; + + if (statePtr->acceptEventCount <= 0) { + statePtr->readyEvents &= ~(FD_ACCEPT); } - return TCL_ERROR; - } - } -#ifdef TCL_FEATURE_KEEPALIVE_NAGLE - if (len == 0 || !strncmp(optionName, "-keepalive", len)) { - int optlen; - BOOL opt = FALSE; + SetEvent(tsdPtr->socketListLock); - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-keepalive"); - } - optlen = sizeof(BOOL); - getsockopt(sock, SOL_SOCKET, SO_KEEPALIVE, (char *)&opt, &optlen); - if (opt) { - Tcl_DStringAppendElement(dsPtr, "1"); - } else { - Tcl_DStringAppendElement(dsPtr, "0"); - } - if (len > 0) { - return TCL_OK; + /* Caution: TcpAccept() has the side-effect of evaluating the server + * accept script (via AcceptCallbackProc() in tclIOCmd.c), which can + * close the server socket and invalidate statePtr and fds. + * If TcpAccept() accepts a socket we must return immediately and let + * SocketCheckProc queue additional FD_ACCEPT events. + */ + TcpAccept(fds, newSocket, addr); + return 1; } + + /* Loop terminated with no sockets accepted; clear the ready mask so + * we can detect the next connection request. Note that connection + * requests are level triggered, so if there is a request already + * pending, a new event will be generated. + */ + statePtr->acceptEventCount = 0; + statePtr->readyEvents &= ~(FD_ACCEPT); + + SetEvent(tsdPtr->socketListLock); + return 1; } - if (len == 0 || !strncmp(optionName, "-nagle", len)) { - int optlen; - BOOL opt = FALSE; + SetEvent(tsdPtr->socketListLock); + + /* + * Mask off unwanted events and compute the read/write mask so we can + * notify the channel. + */ + + events = statePtr->readyEvents & statePtr->watchEvents; + + if (events & FD_CLOSE) { + /* + * If the socket was closed and the channel is still interested in + * read events, then we need to ensure that we keep polling for this + * event until someone does something with the channel. Note that we + * do this before calling Tcl_NotifyChannel so we don't have to watch + * out for the channel being deleted out from under us. This may cause + * a redundant trip through the event loop, but it's simpler than + * trying to do unwind protection. + */ + + Tcl_Time blockTime = { 0, 0 }; + + Tcl_SetMaxBlockTime(&blockTime); + mask |= TCL_READABLE|TCL_WRITABLE; + } else if (events & FD_READ) { + + /* + * Throw the readable event if an async connect failed. + */ + + if ( statePtr->flags & TCP_ASYNC_FAILED ) { + + mask |= TCL_READABLE; - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-nagle"); - } - optlen = sizeof(BOOL); - getsockopt(sock, IPPROTO_TCP, TCP_NODELAY, (char *)&opt, - &optlen); - if (opt) { - Tcl_DStringAppendElement(dsPtr, "0"); } else { - Tcl_DStringAppendElement(dsPtr, "1"); - } - if (len > 0) { - return TCL_OK; + fd_set readFds; + struct timeval timeout; + + /* + * We must check to see if data is really available, since someone + * could have consumed the data in the meantime. Turn off async + * notification so select will work correctly. If the socket is + * still readable, notify the channel driver, otherwise reset the + * async select handler and keep waiting. + */ + + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, + (WPARAM) UNSELECT, (LPARAM) statePtr); + + FD_ZERO(&readFds); + FD_SET(statePtr->sockets->fd, &readFds); + timeout.tv_usec = 0; + timeout.tv_sec = 0; + + if (select(0, &readFds, NULL, NULL, &timeout) != 0) { + mask |= TCL_READABLE; + } else { + statePtr->readyEvents &= ~(FD_READ); + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, + (WPARAM) SELECT, (LPARAM) statePtr); + } } } -#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/ - if (len > 0) { -#ifdef TCL_FEATURE_KEEPALIVE_NAGLE - return Tcl_BadChannelOption(interp, optionName, - "peername sockname keepalive nagle"); -#else - return Tcl_BadChannelOption(interp, optionName, "peername sockname"); -#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/ + /* + * writable event + */ + + if (events & FD_WRITE) { + mask |= TCL_WRITABLE; } - return TCL_OK; + /* + * Call registered event procedures + */ + + if (mask) { + Tcl_NotifyChannel(statePtr->channel, mask); + } + return 1; } /* *---------------------------------------------------------------------- * - * TcpWatchProc -- + * AddSocketInfoFd -- * - * Informs the channel driver of the events that the generic channel code - * wishes to receive on this socket. + * This function adds a SOCKET file descriptor to the 'sockets' linked + * list of a TcpState structure. * * Results: * None. * * Side effects: - * May cause the notifier to poll if any of the specified conditions are - * already true. + * None, except for allocation of memory. * *---------------------------------------------------------------------- */ static void -TcpWatchProc( - ClientData instanceData, /* The socket state. */ - int mask) /* Events of interest; an OR-ed combination of - * TCL_READABLE, TCL_WRITABLE and - * TCL_EXCEPTION. */ +AddSocketInfoFd( + TcpState *statePtr, + SOCKET socket) { - SocketInfo *infoPtr = (SocketInfo *) instanceData; + TcpFdList *fds = statePtr->sockets; + + if ( fds == NULL ) { + /* Add the first FD */ + statePtr->sockets = ckalloc(sizeof(TcpFdList)); + fds = statePtr->sockets; + } else { + /* Find end of list and append FD */ + while ( fds->next != NULL ) { + fds = fds->next; + } + + fds->next = ckalloc(sizeof(TcpFdList)); + fds = fds->next; + } + + /* Populate new FD */ + fds->fd = socket; + fds->statePtr = statePtr; + fds->next = NULL; +} + + +/* + *---------------------------------------------------------------------- + * + * NewSocketInfo -- + * + * This function allocates and initializes a new TcpState structure. + * + * Results: + * Returns a newly allocated TcpState. + * + * Side effects: + * None, except for allocation of memory. + * + *---------------------------------------------------------------------- + */ + +static TcpState * +NewSocketInfo(SOCKET socket) +{ + TcpState *statePtr = ckalloc(sizeof(TcpState)); + + memset(statePtr, 0, sizeof(TcpState)); /* - * Update the watch events mask. Only if the socket is not a server - * socket. Fix for SF Tcl Bug #557878. + * TIP #218. Removed the code inserting the new structure into the global + * list. This is now handled in the thread action callbacks, and only + * there. */ - if (!infoPtr->acceptProc) { - infoPtr->watchEvents = 0; - if (mask & TCL_READABLE) { - infoPtr->watchEvents |= (FD_READ|FD_CLOSE|FD_ACCEPT); - } - if (mask & TCL_WRITABLE) { - infoPtr->watchEvents |= (FD_WRITE|FD_CLOSE|FD_CONNECT); - } - - /* - * If there are any conditions already set, then tell the notifier to - * poll rather than block. - */ + AddSocketInfoFd(statePtr, socket); - if (infoPtr->readyEvents & infoPtr->watchEvents) { - Tcl_Time blockTime = { 0, 0 }; - Tcl_SetMaxBlockTime(&blockTime); - } - } + return statePtr; } /* *---------------------------------------------------------------------- * - * TcpGetProc -- + * WaitForSocketEvent -- * - * Called from Tcl_GetChannelHandle to retrieve an OS handle from inside - * a TCP socket based channel. + * Waits until one of the specified events occurs on a socket. + * For event FD_CONNECT use WaitForConnect. * * Results: - * Returns TCL_OK with the socket in handlePtr. + * Returns 1 on success or 0 on failure, with an error code in + * errorCodePtr. * * Side effects: - * None. + * Processes socket events off the system queue. * *---------------------------------------------------------------------- */ static int -TcpGetHandleProc( - ClientData instanceData, /* The socket state. */ - int direction, /* Not used. */ - ClientData *handlePtr) /* Where to store the handle. */ +WaitForSocketEvent( + TcpState *statePtr, /* Information about this socket. */ + int events, /* Events to look for. May be one of + * FD_READ or FD_WRITE. + */ + int *errorCodePtr) /* Where to store errors? */ { - SocketInfo *statePtr = (SocketInfo *) instanceData; + int result = 1; + int oldMode; + ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + /* + * Be sure to disable event servicing so we are truly modal. + */ - *handlePtr = (ClientData) statePtr->socket; - return TCL_OK; + oldMode = Tcl_SetServiceMode(TCL_SERVICE_NONE); + + /* + * Reset WSAAsyncSelect so we have a fresh set of events pending. + */ + + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT, + (LPARAM) statePtr); + SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, + (LPARAM) statePtr); + + while (1) { + int event_found; + + /* get statePtr lock */ + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + + /* Check if event occured */ + event_found = (statePtr->readyEvents & events); + + /* Free list lock */ + SetEvent(tsdPtr->socketListLock); + + /* exit loop if event occured */ + if (event_found) { + break; + } + + /* Exit loop if event did not occur but this is a non-blocking channel */ + if (statePtr->flags & TCP_NONBLOCKING) { + *errorCodePtr = EWOULDBLOCK; + result = 0; + break; + } + + /* + * Wait until something happens. + */ + + WaitForSingleObject(tsdPtr->readyEvent, INFINITE); + } + + (void) Tcl_SetServiceMode(oldMode); + return result; } /* @@ -2224,14 +2986,14 @@ SocketThread( LPVOID arg) { MSG msg; - ThreadSpecificData *tsdPtr = (ThreadSpecificData *)(arg); + ThreadSpecificData *tsdPtr = arg; /* * Create a dummy window receiving socket events. */ - tsdPtr->hwnd = CreateWindow("TclSocket", "TclSocket", - WS_TILED, 0, 0, 0, 0, NULL, NULL, windowClass.hInstance, arg); + tsdPtr->hwnd = CreateWindow(classname, classname, WS_TILED, 0, 0, 0, 0, + NULL, NULL, windowClass.hInstance, arg); /* * Signalize thread creator that we are done creating the window. @@ -2294,8 +3056,9 @@ SocketProc( { int event, error; SOCKET socket; - SocketInfo *infoPtr; + TcpState *statePtr; int info_found = 0; + TcpFdList *fds = NULL; ThreadSpecificData *tsdPtr = (ThreadSpecificData *) #ifdef _WIN64 GetWindowLongPtr(hwnd, GWLP_USERDATA); @@ -2332,15 +3095,16 @@ SocketProc( error = WSAGETSELECTERROR(lParam); socket = (SOCKET) wParam; + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + /* * Find the specified socket on the socket list and update its * eventState flag. */ - WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - for (infoPtr = tsdPtr->socketList; infoPtr != NULL; - infoPtr = infoPtr->nextPtr) { - if (infoPtr->socket == socket) { + for (statePtr = tsdPtr->socketList; statePtr != NULL; + statePtr = statePtr->nextPtr) { + if ( FindFDInList(statePtr,socket) ) { info_found = 1; break; } @@ -2350,9 +3114,9 @@ SocketProc( * list */ if ( !info_found - && tsdPtr->pendingSocketInfo != NULL - && tsdPtr->pendingSocketInfo->socket ==socket ) { - infoPtr = tsdPtr->pendingSocketInfo; + && tsdPtr->pendingTcpState != NULL + && FindFDInList(tsdPtr->pendingTcpState,socket) ) { + statePtr = tsdPtr->pendingTcpState; info_found = 1; } if (info_found) { @@ -2366,44 +3130,29 @@ SocketProc( */ if (event & FD_CLOSE) { - infoPtr->acceptEventCount = 0; - infoPtr->readyEvents &= ~(FD_WRITE|FD_ACCEPT); + statePtr->acceptEventCount = 0; + statePtr->readyEvents &= ~(FD_WRITE|FD_ACCEPT); } else if (event & FD_ACCEPT) { - infoPtr->acceptEventCount++; + statePtr->acceptEventCount++; } if (event & FD_CONNECT) { /* - * The socket is now connected, clear the async connect - * flag. - */ - - infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT); - - /* * Remember any error that occurred so we can report * connection failures. */ - if (error != ERROR_SUCCESS) { - /* Async Connect error */ - TclWinConvertWSAError((DWORD) error); - infoPtr->lastError = Tcl_GetErrno(); - /* Fire also readable event on connect failure */ - infoPtr->readyEvents |= FD_READ; + statePtr->notifierConnectError = error; } - - /* fire writable event on connect */ - infoPtr->readyEvents |= FD_WRITE; - } - - infoPtr->readyEvents |= event; + /* + * Inform main thread about signaled events + */ + statePtr->readyEvents |= event; /* * Wake up the Main Thread. */ - SetEvent(tsdPtr->readyEvent); Tcl_ThreadAlert(tsdPtr->threadId); } @@ -2411,20 +3160,18 @@ SocketProc( break; case SOCKET_SELECT: - infoPtr = (SocketInfo *) lParam; - if (wParam == SELECT) { - /* - * Start notification by windows messages on socket events - */ - - WSAAsyncSelect(infoPtr->socket, hwnd, - SOCKET_MESSAGE, infoPtr->selectEvents); - } else { - /* - * UNSELECT: Clear the selection mask - */ + statePtr = (TcpState *) lParam; + for (fds = statePtr->sockets; fds != NULL; fds = fds->next) { + if (wParam == SELECT) { + WSAAsyncSelect(fds->fd, hwnd, + SOCKET_MESSAGE, statePtr->selectEvents); + } else { + /* + * Clear the selection mask + */ - WSAAsyncSelect(infoPtr->socket, hwnd, 0, 0); + WSAAsyncSelect(fds->fd, hwnd, 0, 0); + } } break; @@ -2439,83 +3186,31 @@ SocketProc( /* *---------------------------------------------------------------------- * - * Tcl_GetHostName -- + * FindFDInList -- * - * Returns the name of the local host. + * Return true, if the given file descriptior is contained in the + * file descriptor list. * * Results: - * A string containing the network name for this machine. The caller must - * not modify or free this string. + * true if found. * * Side effects: - * Caches the name to return for future calls. * *---------------------------------------------------------------------- */ -const char * -Tcl_GetHostName(void) -{ - return Tcl_GetString(TclGetProcessGlobalValue(&hostName)); -} - -/* - *---------------------------------------------------------------------- - * - * InitializeHostName -- - * - * This routine sets the process global value of the name of the local - * host on which the process is running. - * - * Results: - * None. - * - *---------------------------------------------------------------------- - */ - -void -InitializeHostName( - char **valuePtr, - int *lengthPtr, - Tcl_Encoding *encodingPtr) +static int +FindFDInList( + TcpState *statePtr, + SOCKET socket) { - WCHAR wbuf[MAX_COMPUTERNAME_LENGTH + 1]; - DWORD length = sizeof(wbuf) / sizeof(WCHAR); - Tcl_DString ds; - - if ((*tclWinProcs->getComputerNameProc)(wbuf, &length) != 0) { - /* - * Convert string from native to UTF then change to lowercase. - */ - - Tcl_UtfToLower(Tcl_WinTCharToUtf((TCHAR *) wbuf, -1, &ds)); - - } else { - Tcl_DStringInit(&ds); - if (TclpHasSockets(NULL) == TCL_OK) { - /* - * The buffer size of 256 is recommended by the MSDN page that - * documents gethostname() as being always adequate. - */ - - Tcl_DString inDs; - - Tcl_DStringInit(&inDs); - Tcl_DStringSetLength(&inDs, 256); - if (gethostname(Tcl_DStringValue(&inDs), - Tcl_DStringLength(&inDs)) == 0) { - Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&inDs), -1, - &ds); - } - Tcl_DStringFree(&inDs); + TcpFdList *fds; + for (fds = statePtr->sockets; fds != NULL; fds = fds->next) { + if (fds->fd == socket) { + return 1; } } - - *encodingPtr = Tcl_GetEncoding(NULL, "utf-8"); - *lengthPtr = Tcl_DStringLength(&ds); - *valuePtr = ckalloc((unsigned int) (*lengthPtr)+1); - memcpy(*valuePtr, Tcl_DStringValue(&ds), (size_t)(*lengthPtr)+1); - Tcl_DStringFree(&ds); + return 0; } /* @@ -2523,10 +3218,11 @@ InitializeHostName( * * TclWinGetSockOpt, et al. -- * - * These functions are wrappers that let us bind the WinSock API - * dynamically so we can run on systems that don't have the wsock32.dll. - * We need wrappers for these interfaces because they are called from the - * generic Tcl code. + * Those functions are historically exported by the stubs table and + * just use the original system calls now. + * + * Warning: + * Those functions are depreciated and will be removed with TCL 9.0. * * Results: * As defined for each function. @@ -2539,26 +3235,35 @@ InitializeHostName( #undef TclWinGetSockOpt int -TclWinGetSockOpt(SOCKET s, int level, int optname, char *optval, - int *optlen) +TclWinGetSockOpt( + SOCKET s, + int level, + int optname, + char *optval, + int *optlen) { + return getsockopt(s, level, optname, optval, optlen); } - #undef TclWinSetSockOpt int -TclWinSetSockOpt(SOCKET s, int level, int optname, const char *optval, +TclWinSetSockOpt( + SOCKET s, + int level, + int optname, + const char *optval, int optlen) { return setsockopt(s, level, optname, optval, optlen); } +#undef TclpInetNtoa char * -TclpInetNtoa(struct in_addr addr) +TclpInetNtoa( + struct in_addr addr) { return inet_ntoa(addr); } - #undef TclWinGetServByName struct servent * TclWinGetServByName( @@ -2590,7 +3295,7 @@ TcpThreadActionProc( int action) { ThreadSpecificData *tsdPtr; - SocketInfo *infoPtr = (SocketInfo *) instanceData; + TcpState *statePtr = instanceData; int notifyCmd; if (action == TCL_CHANNEL_THREAD_INSERT) { @@ -2606,18 +3311,18 @@ TcpThreadActionProc( tsdPtr = TCL_TSD_INIT(&dataKey); WaitForSingleObject(tsdPtr->socketListLock, INFINITE); - infoPtr->nextPtr = tsdPtr->socketList; - tsdPtr->socketList = infoPtr; - - if (infoPtr == tsdPtr->pendingSocketInfo) { - tsdPtr->pendingSocketInfo = NULL; + statePtr->nextPtr = tsdPtr->socketList; + tsdPtr->socketList = statePtr; + + if (statePtr == tsdPtr->pendingTcpState) { + tsdPtr->pendingTcpState = NULL; } - + SetEvent(tsdPtr->socketListLock); notifyCmd = SELECT; } else { - SocketInfo **nextPtrPtr; + TcpState **nextPtrPtr; int removed = 0; tsdPtr = TCL_TSD_INIT(&dataKey); @@ -2630,8 +3335,8 @@ TcpThreadActionProc( WaitForSingleObject(tsdPtr->socketListLock, INFINITE); for (nextPtrPtr = &(tsdPtr->socketList); (*nextPtrPtr) != NULL; nextPtrPtr = &((*nextPtrPtr)->nextPtr)) { - if ((*nextPtrPtr) == infoPtr) { - (*nextPtrPtr) = infoPtr->nextPtr; + if ((*nextPtrPtr) == statePtr) { + (*nextPtrPtr) = statePtr->nextPtr; removed = 1; break; } @@ -2657,7 +3362,7 @@ TcpThreadActionProc( */ SendMessage(tsdPtr->hwnd, SOCKET_SELECT, - (WPARAM) notifyCmd, (LPARAM) infoPtr); + (WPARAM) notifyCmd, (LPARAM) statePtr); } /* @@ -2665,5 +3370,7 @@ TcpThreadActionProc( * mode: c * c-basic-offset: 4 * fill-column: 78 + * tab-width: 8 + * indent-tabs-mode: nil * End: */ diff --git a/win/tclWinTest.c b/win/tclWinTest.c index 7f49b63..b2fe6c0 100644 --- a/win/tclWinTest.c +++ b/win/tclWinTest.c @@ -9,12 +9,15 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ +#ifndef USE_TCL_STUBS +# define USE_TCL_STUBS +#endif #include "tclInt.h" /* * For TestplatformChmod on Windows */ -#ifdef __WIN32__ +#ifdef _WIN32 #include <aclapi.h> #endif @@ -29,9 +32,8 @@ * Forward declarations of functions defined later in this file: */ -int TclplatformtestInit(Tcl_Interp *interp); -static int TesteventloopCmd(ClientData dummy, Tcl_Interp *interp, - int argc, const char **argv); +static int TesteventloopCmd(ClientData dummy, Tcl_Interp* interp, + int objc, Tcl_Obj *const objv[]); static int TestvolumetypeCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -41,8 +43,8 @@ static int TestwinsleepCmd(ClientData dummy, Tcl_Interp* interp, int objc, Tcl_Obj *const objv[]); static Tcl_ObjCmdProc TestExceptionCmd; static int TestplatformChmod(const char *nativePath, int pmode); -static int TestchmodCmd(ClientData dummy, - Tcl_Interp *interp, int argc, const char **argv); +static int TestchmodCmd(ClientData dummy, Tcl_Interp* interp, + int objc, Tcl_Obj *const objv[]); /* *---------------------------------------------------------------------- @@ -69,8 +71,8 @@ TclplatformtestInit( * Add commands for platform specific tests for Windows here. */ - Tcl_CreateCommand(interp, "testchmod", TestchmodCmd, NULL, NULL); - Tcl_CreateCommand(interp, "testeventloop", TesteventloopCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testchmod", TestchmodCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testeventloop", TesteventloopCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testvolumetype", TestvolumetypeCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testwinclock", TestwinclockCmd, NULL, NULL); @@ -101,21 +103,20 @@ static int TesteventloopCmd( ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - const char **argv) /* Argument strings. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { static int *framePtr = NULL;/* Pointer to integer on stack frame of * innermost invocation of the "wait" * subcommand. */ - if (argc < 2) { - Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0], - " option ... \"", NULL); + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option ..."); return TCL_ERROR; } - if (strcmp(argv[1], "done") == 0) { + if (strcmp(Tcl_GetString(objv[1]), "done") == 0) { *framePtr = 1; - } else if (strcmp(argv[1], "wait") == 0) { + } else if (strcmp(Tcl_GetString(objv[1]), "wait") == 0) { int *oldFramePtr, done; int oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL); @@ -150,7 +151,7 @@ TesteventloopCmd( (void) Tcl_SetServiceMode(oldMode); framePtr = oldFramePtr; } else { - Tcl_AppendResult(interp, "bad option \"", argv[1], + Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]), "\": must be done or wait", NULL); return TCL_ERROR; } @@ -184,7 +185,7 @@ TestvolumetypeCmd( #define VOL_BUF_SIZE 32 int found; char volType[VOL_BUF_SIZE]; - char *path; + const char *path; if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "?name?"); @@ -209,7 +210,7 @@ TestvolumetypeCmd( TclWinConvertError(GetLastError()); return TCL_ERROR; } - Tcl_SetResult(interp, volType, TCL_VOLATILE); + Tcl_AppendResult(interp, volType, NULL); return TCL_OK; #undef VOL_BUF_SIZE } @@ -339,7 +340,7 @@ TestExceptionCmd( int objc, /* Argument count */ Tcl_Obj *const objv[]) /* Argument vector */ { - static const char *cmds[] = { + static const char *const cmds[] = { "access_violation", "datatype_misalignment", "array_bounds", "float_denormal", "float_divbyzero", "float_inexact", "float_invalidop", "float_overflow", "float_stack", "float_underflow", @@ -396,28 +397,6 @@ TestplatformChmod( const char *nativePath, int pmode) { - typedef DWORD (WINAPI *getSidLengthRequiredDef)(UCHAR); - typedef BOOL (WINAPI *initializeSidDef)(PSID, PSID_IDENTIFIER_AUTHORITY, - BYTE); - typedef PDWORD (WINAPI *getSidSubAuthorityDef)(PSID, DWORD); - typedef DWORD (WINAPI *setNamedSecurityInfoADef)(IN LPSTR, - IN SE_OBJECT_TYPE, IN SECURITY_INFORMATION, IN PSID, IN PSID, - IN PACL, IN PACL); - typedef BOOL (WINAPI *getAceDef)(PACL, DWORD, LPVOID *); - typedef BOOL (WINAPI *addAceDef)(PACL, DWORD, DWORD, LPVOID, DWORD); - typedef BOOL (WINAPI *equalSidDef)(PSID, PSID); - typedef BOOL (WINAPI *addAccessDeniedAceDef)(PACL, DWORD, DWORD, PSID); - typedef BOOL (WINAPI *initializeAclDef)(PACL, DWORD, DWORD); - typedef DWORD (WINAPI *getLengthSidDef)(PSID); - typedef BOOL (WINAPI *getAclInformationDef)(PACL, LPVOID, DWORD, - ACL_INFORMATION_CLASS); - typedef BOOL (WINAPI *getSecurityDescriptorDaclDef)(PSECURITY_DESCRIPTOR, - LPBOOL, PACL *, LPBOOL); - typedef BOOL (WINAPI *lookupAccountNameADef)(LPCSTR, LPCSTR, PSID, - PDWORD, LPSTR, LPDWORD, PSID_NAME_USE); - typedef BOOL (WINAPI *getFileSecurityADef)(LPCSTR, SECURITY_INFORMATION, - PSECURITY_DESCRIPTOR, DWORD, LPDWORD); - static const SECURITY_INFORMATION infoBits = OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION; /* don't deny DELETE mask (reset writable only, allow test-cases cleanup) */ @@ -430,22 +409,6 @@ TestplatformChmod( * References to security functions (only available on NT and later). */ - static getSidLengthRequiredDef getSidLengthRequiredProc; - static initializeSidDef initializeSidProc; - static getSidSubAuthorityDef getSidSubAuthorityProc; - static setNamedSecurityInfoADef setNamedSecurityInfoProc; - static getAceDef getAceProc; - static addAceDef addAceProc; - static equalSidDef equalSidProc; - static addAccessDeniedAceDef addAccessDeniedAceProc; - static initializeAclDef initializeAclProc; - static getLengthSidDef getLengthSidProc; - static getAclInformationDef getAclInformationProc; - static getSecurityDescriptorDaclDef getSecurityDescriptorDaclProc; - static lookupAccountNameADef lookupAccountNameProc; - static getFileSecurityADef getFileSecurityProc; - static int initialized = 0; - const BOOL set_readOnly = !(pmode & 0222); BOOL acl_readOnly_found = FALSE, curAclPresent, curAclDefaulted; SID_IDENTIFIER_AUTHORITY userSidAuthority = { @@ -457,75 +420,14 @@ TestplatformChmod( PACL curAcl, newAcl = 0; WORD j; SID *userSid = 0; - TCHAR *userDomain = 0; + char *userDomain = 0; int res = 0; /* - * One time initialization, dynamically load Windows NT features - */ - - if (!initialized) { - TCL_DECLARE_MUTEX(initializeMutex) - Tcl_MutexLock(&initializeMutex); - if (!initialized) { - HMODULE handle = GetModuleHandle(TEXT("ADVAPI32")); - if (handle == NULL) { - handle = GetModuleHandle(TEXT("ADVAPI")); - } - - if (handle != NULL) { - setNamedSecurityInfoProc = (setNamedSecurityInfoADef) - GetProcAddress(handle, "SetNamedSecurityInfoA"); - getFileSecurityProc = (getFileSecurityADef) - GetProcAddress(handle, "GetFileSecurityA"); - getAceProc = (getAceDef) - GetProcAddress(handle, "GetAce"); - addAceProc = (addAceDef) - GetProcAddress(handle, "AddAce"); - equalSidProc = (equalSidDef) - GetProcAddress(handle, "EqualSid"); - addAccessDeniedAceProc = (addAccessDeniedAceDef) - GetProcAddress(handle, "AddAccessDeniedAce"); - initializeAclProc = (initializeAclDef) - GetProcAddress(handle, "InitializeAcl"); - getLengthSidProc = (getLengthSidDef) - GetProcAddress(handle, "GetLengthSid"); - getAclInformationProc = (getAclInformationDef) - GetProcAddress(handle, "GetAclInformation"); - getSecurityDescriptorDaclProc = (getSecurityDescriptorDaclDef) - GetProcAddress(handle, "GetSecurityDescriptorDacl"); - lookupAccountNameProc = (lookupAccountNameADef) - GetProcAddress(handle, "LookupAccountNameA"); - getSidLengthRequiredProc = (getSidLengthRequiredDef) - GetProcAddress(handle, "GetSidLengthRequired"); - initializeSidProc = (initializeSidDef) - GetProcAddress(handle, "InitializeSid"); - getSidSubAuthorityProc = (getSidSubAuthorityDef) - GetProcAddress(handle, "GetSidSubAuthority"); - - if (setNamedSecurityInfoProc && getAceProc && addAceProc - && equalSidProc && addAccessDeniedAceProc - && initializeAclProc && getLengthSidProc - && getAclInformationProc - && getSecurityDescriptorDaclProc - && lookupAccountNameProc && getFileSecurityProc - && getSidLengthRequiredProc && initializeSidProc - && getSidSubAuthorityProc) { - initialized = 1; - } - } - if (!initialized) { - initialized = -1; - } - } - Tcl_MutexUnlock(&initializeMutex); - } - - /* * Process the chmod request. */ - attr = GetFileAttributes(nativePath); + attr = GetFileAttributesA(nativePath); /* * nativePath not found @@ -537,11 +439,10 @@ TestplatformChmod( } /* - * If no ACL API is present or nativePath is not a directory, there is no - * special handling. + * If nativePath is not a directory, there is no special handling. */ - if (initialized < 0 || !(attr & FILE_ATTRIBUTE_DIRECTORY)) { + if (!(attr & FILE_ATTRIBUTE_DIRECTORY)) { goto done; } @@ -557,15 +458,15 @@ TestplatformChmod( * obtains the size of the security descriptor. */ - if (!getFileSecurityProc(nativePath, infoBits, NULL, 0, &secDescLen)) { + if (!GetFileSecurityA(nativePath, infoBits, NULL, 0, &secDescLen)) { DWORD secDescLen2 = 0; if (GetLastError() != ERROR_INSUFFICIENT_BUFFER) { goto done; } - secDesc = (BYTE *) ckalloc(secDescLen); - if (!getFileSecurityProc(nativePath, infoBits, + secDesc = ckalloc(secDescLen); + if (!GetFileSecurityA(nativePath, infoBits, (PSECURITY_DESCRIPTOR) secDesc, secDescLen, &secDescLen2) || (secDescLen < secDescLen2)) { goto done; @@ -576,22 +477,22 @@ TestplatformChmod( * Get the World SID. */ - userSid = (SID *) ckalloc(getSidLengthRequiredProc((UCHAR) 1)); - initializeSidProc(userSid, &userSidAuthority, (BYTE) 1); - *(getSidSubAuthorityProc(userSid, 0)) = SECURITY_WORLD_RID; + userSid = ckalloc(GetSidLengthRequired((UCHAR) 1)); + InitializeSid(userSid, &userSidAuthority, (BYTE) 1); + *(GetSidSubAuthority(userSid, 0)) = SECURITY_WORLD_RID; /* * If curAclPresent == false then curAcl and curAclDefaulted not valid. */ - if (!getSecurityDescriptorDaclProc((PSECURITY_DESCRIPTOR) secDesc, + if (!GetSecurityDescriptorDacl((PSECURITY_DESCRIPTOR) secDesc, &curAclPresent, &curAcl, &curAclDefaulted)) { goto done; } if (!curAclPresent || !curAcl) { ACLSize.AclBytesInUse = 0; ACLSize.AceCount = 0; - } else if (!getAclInformationProc(curAcl, &ACLSize, sizeof(ACLSize), + } else if (!GetAclInformation(curAcl, &ACLSize, sizeof(ACLSize), AclSizeInformation)) { goto done; } @@ -601,14 +502,14 @@ TestplatformChmod( */ newAclSize = ACLSize.AclBytesInUse + sizeof(ACCESS_DENIED_ACE) - + getLengthSidProc(userSid) - sizeof(DWORD); - newAcl = (ACL *) ckalloc(newAclSize); + + GetLengthSid(userSid) - sizeof(DWORD); + newAcl = ckalloc(newAclSize); /* * Initialize the new ACL. */ - if (!initializeAclProc(newAcl, newAclSize, ACL_REVISION)) { + if (!InitializeAcl(newAcl, newAclSize, ACL_REVISION)) { goto done; } @@ -616,7 +517,7 @@ TestplatformChmod( * Add denied to make readonly, this will be known as a "read-only tag". */ - if (set_readOnly && !addAccessDeniedAceProc(newAcl, ACL_REVISION, + if (set_readOnly && !AddAccessDeniedAce(newAcl, ACL_REVISION, readOnlyMask, userSid)) { goto done; } @@ -626,7 +527,7 @@ TestplatformChmod( LPVOID pACE2; ACE_HEADER *phACE2; - if (!getAceProc(curAcl, j, &pACE2)) { + if (!GetAce(curAcl, j, &pACE2)) { goto done; } @@ -649,7 +550,7 @@ TestplatformChmod( ACCESS_DENIED_ACE *pACEd = (ACCESS_DENIED_ACE *) phACE2; if (pACEd->Mask == readOnlyMask - && equalSidProc(userSid, (PSID) &pACEd->SidStart)) { + && EqualSid(userSid, (PSID) &pACEd->SidStart)) { acl_readOnly_found = TRUE; continue; } @@ -659,7 +560,7 @@ TestplatformChmod( * Copy the current ACE from the old to the new ACL. */ - if (!addAceProc(newAcl, ACL_REVISION, MAXDWORD, (PACL *)pACE2, + if (!AddAce(newAcl, ACL_REVISION, MAXDWORD, (PACL *) pACE2, ((PACE_HEADER) pACE2)->AceSize)) { goto done; } @@ -670,7 +571,7 @@ TestplatformChmod( * to remove inherited ACL (we need to overwrite the default ACL's in this case) */ - if (set_readOnly == acl_readOnly_found || setNamedSecurityInfoProc( + if (set_readOnly == acl_readOnly_found || SetNamedSecurityInfoA( (LPSTR) nativePath, SE_FILE_OBJECT, DACL_SECURITY_INFORMATION /*| PROTECTED_DACL_SECURITY_INFORMATION*/, NULL, NULL, newAcl, NULL) == ERROR_SUCCESS) { @@ -679,13 +580,13 @@ TestplatformChmod( done: if (secDesc) { - ckfree((char *) secDesc); + ckfree(secDesc); } if (newAcl) { - ckfree((char *) newAcl); + ckfree(newAcl); } if (userSid) { - ckfree((char *) userSid); + ckfree(userSid); } if (userDomain) { ckfree(userDomain); @@ -725,29 +626,25 @@ static int TestchmodCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ - int argc, /* Number of arguments. */ - const char **argv) /* Argument strings. */ + int objc, /* Parameter count */ + Tcl_Obj *const * objv) /* Parameter vector */ { int i, mode; - char *rest; - if (argc < 2) { - usage: - Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], - " mode file ?file ...?", NULL); + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "mode file ?file ...?"); return TCL_ERROR; } - mode = (int) strtol(argv[1], &rest, 8); - if ((rest == argv[1]) || (*rest != '\0')) { - goto usage; + if (Tcl_GetIntFromObj(interp, objv[1], &mode) != TCL_OK) { + return TCL_ERROR; } - for (i = 2; i < argc; i++) { + for (i = 2; i < objc; i++) { Tcl_DString buffer; const char *translated; - translated = Tcl_TranslateFileName(interp, argv[i], &buffer); + translated = Tcl_TranslateFileName(interp, Tcl_GetString(objv[i]), &buffer); if (translated == NULL) { return TCL_ERROR; } diff --git a/win/tclWinThrd.c b/win/tclWinThrd.c index 7828e65..0f83526 100644 --- a/win/tclWinThrd.c +++ b/win/tclWinThrd.c @@ -5,6 +5,7 @@ * * Copyright (c) 1998 by Sun Microsystems, Inc. * Copyright (c) 1999 by Scriptics Corporation + * Copyright (c) 2008 by George Peter Staplin * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -207,7 +208,7 @@ TclWinThreadStart( int TclpThreadCreate( Tcl_ThreadId *idPtr, /* Return, the ID of the thread. */ - Tcl_ThreadCreateProc proc, /* Main() function of the thread. */ + Tcl_ThreadCreateProc *proc, /* Main() function of the thread. */ ClientData clientData, /* The one argument to Main(). */ int stackSize, /* Size of stack for the new thread. */ int flags) /* Flags controlling behaviour of the new @@ -246,7 +247,7 @@ TclpThreadCreate( /* * The only purpose of this is to decrement the reference count so the - * OS resources will be reaquired when the thread closes. + * OS resources will be reacquired when the thread closes. */ CloseHandle(tHandle); @@ -331,7 +332,7 @@ TclpThreadExit( Tcl_ThreadId Tcl_GetCurrentThread(void) { - return (Tcl_ThreadId) INT2PTR(GetCurrentThreadId()); + return (Tcl_ThreadId)(size_t)GetCurrentThreadId(); } /* @@ -404,7 +405,7 @@ TclpInitUnlock(void) * mutexes, condition variables, and thread local storage keys. * * This lock must be different than the initLock because the initLock is - * held during creation of syncronization objects. + * held during creation of synchronization objects. * * Results: * None. @@ -554,7 +555,7 @@ static void FinalizeConditionEvent(ClientData data); * None. * * Side effects: - * May block the current thread. The mutex is aquired when this returns. + * May block the current thread. The mutex is acquired when this returns. * *---------------------------------------------------------------------- */ @@ -573,7 +574,7 @@ Tcl_MutexLock( */ if (*mutexPtr == NULL) { - csPtr = (CRITICAL_SECTION *) ckalloc(sizeof(CRITICAL_SECTION)); + csPtr = ckalloc(sizeof(CRITICAL_SECTION)); InitializeCriticalSection(csPtr); *mutexPtr = (Tcl_Mutex)csPtr; TclRememberMutex(mutexPtr); @@ -634,7 +635,7 @@ TclpFinalizeMutex( if (csPtr != NULL) { DeleteCriticalSection(csPtr); - ckfree((char *) csPtr); + ckfree(csPtr); *mutexPtr = NULL; } } @@ -654,7 +655,7 @@ TclpFinalizeMutex( * None. * * Side effects: - * May block the current thread. The mutex is aquired when this returns. + * May block the current thread. The mutex is acquired when this returns. * Will allocate memory for a HANDLE and initialize this the first time * this Tcl_Condition is used. * @@ -665,7 +666,7 @@ void Tcl_ConditionWait( Tcl_Condition *condPtr, /* Really (WinCondition **) */ Tcl_Mutex *mutexPtr, /* Really (CRITICAL_SECTION **) */ - Tcl_Time *timePtr) /* Timeout on waiting period */ + const Tcl_Time *timePtr) /* Timeout on waiting period */ { WinCondition *winCondPtr; /* Per-condition queue head */ CRITICAL_SECTION *csPtr; /* Caller's Mutex, after casting */ @@ -704,8 +705,7 @@ Tcl_ConditionWait( * and initializing that may drop back into the Master Lock. */ - Tcl_CreateThreadExitHandler(FinalizeConditionEvent, - (ClientData) tsdPtr); + Tcl_CreateThreadExitHandler(FinalizeConditionEvent, tsdPtr); } } @@ -717,7 +717,7 @@ Tcl_ConditionWait( */ if (*condPtr == NULL) { - winCondPtr = (WinCondition *) ckalloc(sizeof(WinCondition)); + winCondPtr = ckalloc(sizeof(WinCondition)); InitializeCriticalSection(&winCondPtr->condLock); winCondPtr->firstPtr = NULL; winCondPtr->lastPtr = NULL; @@ -766,7 +766,8 @@ Tcl_ConditionWait( while (!timeout && (tsdPtr->flags & WIN_THREAD_BLOCKED)) { ResetEvent(tsdPtr->condEvent); LeaveCriticalSection(&winCondPtr->condLock); - if (WaitForSingleObject(tsdPtr->condEvent, wtime) == WAIT_TIMEOUT) { + if (WaitForSingleObjectEx(tsdPtr->condEvent, wtime, + TRUE) == WAIT_TIMEOUT) { timeout = 1; } EnterCriticalSection(&winCondPtr->condLock); @@ -927,7 +928,7 @@ TclpFinalizeCondition( if (winCondPtr != NULL) { DeleteCriticalSection(&winCondPtr->condLock); - ckfree((char *) winCondPtr); + ckfree(winCondPtr); *condPtr = NULL; } } @@ -970,7 +971,7 @@ TclpFreeAllocMutex( void * TclpGetAllocCache(void) { - VOID *result; + void *result; if (!once) { /* @@ -1011,8 +1012,10 @@ TclpFreeAllocCache( if (ptr != NULL) { /* - * Called by us in TclpFinalizeThreadData when a thread exits and - * destroys the tsd key which stores allocator caches. + * Called by TclFinalizeThreadAlloc() and + * TclFinalizeThreadAllocThread() during Tcl_Finalize() or + * Tcl_FinalizeThread(). This function destroys the tsd key which + * stores allocator caches in thread local storage. */ TclFreeAllocCache(ptr); @@ -1035,6 +1038,61 @@ TclpFreeAllocCache( } #endif /* USE_THREAD_ALLOC */ + + +void * +TclpThreadCreateKey(void) +{ + DWORD *key; + + key = TclpSysAlloc(sizeof *key, 0); + if (key == NULL) { + Tcl_Panic("unable to allocate thread key!"); + } + + *key = TlsAlloc(); + + if (*key == TLS_OUT_OF_INDEXES) { + Tcl_Panic("unable to allocate thread-local storage"); + } + + return key; +} + +void +TclpThreadDeleteKey( + void *keyPtr) +{ + DWORD *key = keyPtr; + + if (!TlsFree(*key)) { + Tcl_Panic("unable to delete key"); + } + + TclpSysFree(keyPtr); +} + +void +TclpThreadSetMasterTSD( + void *tsdKeyPtr, + void *ptr) +{ + DWORD *key = tsdKeyPtr; + + if (!TlsSetValue(*key, ptr)) { + Tcl_Panic("unable to set master TSD value"); + } +} + +void * +TclpThreadGetMasterTSD( + void *tsdKeyPtr) +{ + DWORD *key = tsdKeyPtr; + + return TlsGetValue(*key); +} + #endif /* TCL_THREADS */ /* diff --git a/win/tclWinTime.c b/win/tclWinTime.c index 454709d..7f4f7e5 100644 --- a/win/tclWinTime.c +++ b/win/tclWinTime.c @@ -87,7 +87,7 @@ typedef struct TimeInfo { } TimeInfo; static TimeInfo timeInfo = { - { NULL }, + { NULL, 0, 0, NULL, NULL, 0 }, 0, 0, (HANDLE) NULL, @@ -156,7 +156,7 @@ TclpGetSeconds(void) { Tcl_Time t; - (*tclGetTimeProcPtr) (&t, tclTimeClientData); /* Tcl_GetTime inlined. */ + tclGetTimeProcPtr(&t, tclTimeClientData); /* Tcl_GetTime inlined. */ return t.sec; } @@ -190,7 +190,7 @@ TclpGetClicks(void) Tcl_Time now; /* Current Tcl time */ unsigned long retval; /* Value to return */ - (*tclGetTimeProcPtr) (&now, tclTimeClientData); /* Tcl_GetTime inlined */ + tclGetTimeProcPtr(&now, tclTimeClientData); /* Tcl_GetTime inlined */ retval = (now.sec * 1000000) + now.usec; return retval; @@ -200,35 +200,6 @@ TclpGetClicks(void) /* *---------------------------------------------------------------------- * - * TclpGetTimeZone -- - * - * Determines the current timezone. The method varies wildly between - * different Platform implementations, so its hidden in this function. - * - * Results: - * Minutes west of GMT. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclpGetTimeZone( - unsigned long currentTime) -{ - int timeZone; - - tzset(); - timeZone = timezone / 60; - - return timeZone; -} - -/* - *---------------------------------------------------------------------- - * * Tcl_GetTime -- * * Gets the current system time in seconds and microseconds since the @@ -252,7 +223,7 @@ void Tcl_GetTime( Tcl_Time *timePtr) /* Location to store time information. */ { - (*tclGetTimeProcPtr) (timePtr, tclTimeClientData); + tclGetTimeProcPtr(timePtr, tclTimeClientData); } /* @@ -412,7 +383,7 @@ NativeGetTime( WaitForSingleObject(timeInfo.readyEvent, INFINITE); CloseHandle(timeInfo.readyEvent); - Tcl_CreateExitHandler(StopCalibration, (ClientData) NULL); + Tcl_CreateExitHandler(StopCalibration, NULL); } timeInfo.initialized = TRUE; } @@ -536,93 +507,6 @@ StopCalibration( /* *---------------------------------------------------------------------- * - * TclpGetTZName -- - * - * Gets the current timezone string. - * - * Results: - * Returns a pointer to a static string, or NULL on failure. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -char * -TclpGetTZName( - int dst) -{ - int len; - char *zone, *p; - TIME_ZONE_INFORMATION tz; - Tcl_Encoding encoding; - ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - char *name = tsdPtr->tzName; - - /* - * tzset() under Borland doesn't seem to set up tzname[] at all. - * tzset() under MSVC has the following weird observed behavior: - * First time we call "clock format [clock seconds] -format %Z -gmt 1" - * we get "GMT", but on all subsequent calls we get the current time - * ezone string, even though env(TZ) is GMT and the variable _timezone - * is 0. - */ - - name[0] = '\0'; - - zone = getenv("TZ"); - if (zone != NULL) { - /* - * TZ is of form "NST-4:30NDT", where "NST" would be the name of the - * standard time zone for this area, "-4:30" is the offset from GMT in - * hours, and "NDT is the name of the daylight savings time zone in - * this area. The offset and DST strings are optional. - */ - - len = strlen(zone); - if (len > 3) { - len = 3; - } - if (dst != 0) { - /* - * Skip the offset string and get the DST string. - */ - - p = zone + len; - p += strspn(p, "+-:0123456789"); - if (*p != '\0') { - zone = p; - len = strlen(zone); - if (len > 3) { - len = 3; - } - } - } - Tcl_ExternalToUtf(NULL, NULL, zone, len, 0, NULL, name, - sizeof(tsdPtr->tzName), NULL, NULL, NULL); - } - if (name[0] == '\0') { - if (GetTimeZoneInformation(&tz) == TIME_ZONE_ID_UNKNOWN) { - /* - * MSDN: On NT this is returned if DST is not used in the current - * TZ - */ - - dst = 0; - } - encoding = Tcl_GetEncoding(NULL, "unicode"); - Tcl_ExternalToUtf(NULL, encoding, - (char *) ((dst) ? tz.DaylightName : tz.StandardName), -1, - 0, NULL, name, sizeof(tsdPtr->tzName), NULL, NULL, NULL); - Tcl_FreeEncoding(encoding); - } - return name; -} - -/* - *---------------------------------------------------------------------- - * * TclpGetDate -- * * This function converts between seconds and struct tm. If useGMT is @@ -640,7 +524,7 @@ TclpGetTZName( struct tm * TclpGetDate( - CONST time_t *t, + const time_t *t, int useGMT) { struct tm *tmPtr; @@ -1195,7 +1079,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 */ { /* @@ -1226,9 +1110,8 @@ TclpGmtime( struct tm * TclpLocaltime( - CONST time_t *timePtr) /* Pointer to the number of seconds since the + const time_t *timePtr) /* Pointer to the number of seconds since the * local system's epoch */ - { /* * The MS implementation of localtime is thread safe because it returns diff --git a/win/tclooConfig.sh b/win/tclooConfig.sh new file mode 100644 index 0000000..2279542 --- /dev/null +++ b/win/tclooConfig.sh @@ -0,0 +1,19 @@ +# tclooConfig.sh -- +# +# This shell script (for sh) is generated automatically by TclOO's configure +# script, or would be except it has no values that we substitute. It will +# create shell variables for most of the configuration options discovered by +# the configure script. This script is intended to be included by TEA-based +# configure scripts for TclOO extensions so that they don't have to figure +# this all out for themselves. +# +# The information in this file is specific to a single platform. + +# These are mostly empty because no special steps are ever needed from Tcl 8.6 +# onwards; all libraries and include files are just part of Tcl. +TCLOO_LIB_SPEC="" +TCLOO_STUB_LIB_SPEC="" +TCLOO_INCLUDE_SPEC="" +TCLOO_PRIVATE_INCLUDE_SPEC="" +TCLOO_CFLAGS="" +TCLOO_VERSION=1.1.0 diff --git a/win/tclsh.ico b/win/tclsh.ico Binary files differindex 8bcaf48..e254318 100644 --- a/win/tclsh.ico +++ b/win/tclsh.ico |