diff options
Diffstat (limited to 'win')
41 files changed, 42004 insertions, 0 deletions
diff --git a/win/Makefile.in b/win/Makefile.in new file mode 100644 index 0000000..a3275ba --- /dev/null +++ b/win/Makefile.in @@ -0,0 +1,888 @@ +# +# This file is a Makefile for Tcl. If it has the name "Makefile.in" then it +# is a template for a Makefile; to generate the actual Makefile, run +# "./configure", which is a configuration script generated by the "autoconf" +# program (constructs like "@foo@" will get replaced in the actual Makefile. + +VERSION = @TCL_VERSION@ + +#-------------------------------------------------------------------------- +# Things you can change to personalize the Makefile for your own site (you can +# make these changes in either Makefile.in or Makefile, but changes to +# Makefile will get lost if you re-run the configuration script). +#-------------------------------------------------------------------------- + +# Default top-level directories in which to install architecture-specific +# files (exec_prefix) and machine-independent files such as scripts (prefix). +# The values specified here may be overridden at configure-time with the +# --exec-prefix and --prefix options to the "configure" script. + +prefix = @prefix@ +exec_prefix = @exec_prefix@ +bindir = @bindir@ +libdir = @libdir@ +includedir = @includedir@ +datarootdir = @datarootdir@ +mandir = @mandir@ + +# The following definition can be set to non-null for special systems like AFS +# with replication. It allows the pathnames used for installation to be +# different than those used for actually reference files at run-time. +# INSTALL_ROOT is prepended to $prefix and $exec_prefix when installing files. +INSTALL_ROOT = + +# Directory from which applications will reference the library of Tcl scripts +# (note: you can set the TCL_LIBRARY environment variable at run-time to +# override this value): +TCL_LIBRARY = $(prefix)/lib/tcl$(VERSION) + +# Path to use at runtime to refer to LIB_INSTALL_DIR: +LIB_RUNTIME_DIR = $(libdir) + +# Directory in which to install the program tclsh: +BIN_INSTALL_DIR = $(INSTALL_ROOT)$(bindir) + +# Directory in which to install the .a or .so binary for the Tcl library: +LIB_INSTALL_DIR = $(INSTALL_ROOT)$(libdir) + +# Path name to use when installing library scripts. +SCRIPT_INSTALL_DIR = $(INSTALL_ROOT)$(TCL_LIBRARY) + +# Directory in which to install the include file tcl.h: +INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) + +# Directory in which to (optionally) install the private tcl headers: +PRIVATE_INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) + +# Top-level directory in which to install manual entries: +MAN_INSTALL_DIR = $(INSTALL_ROOT)$(mandir) + +# Directory in which to install manual entry for tclsh: +MAN1_INSTALL_DIR = $(MAN_INSTALL_DIR)/man1 + +# Directory in which to install manual entries for Tcl's C library procedures: +MAN3_INSTALL_DIR = $(MAN_INSTALL_DIR)/man3 + +# Directory in which to install manual entries for the built-in Tcl commands: +MANN_INSTALL_DIR = $(MAN_INSTALL_DIR)/mann + +# Libraries built with optimization switches have this additional extension +TCL_DBGX = @TCL_DBGX@ + +# warning flags +CFLAGS_WARNING = @CFLAGS_WARNING@ + +# The default switches for optimization or debugging +CFLAGS_DEBUG = @CFLAGS_DEBUG@ +CFLAGS_OPTIMIZE = @CFLAGS_OPTIMIZE@ + +# To change the compiler switches, for example to change from optimization to +# debugging symbols, change the following line: +#CFLAGS = $(CFLAGS_DEBUG) +#CFLAGS = $(CFLAGS_OPTIMIZE) +#CFLAGS = $(CFLAGS_DEBUG) $(CFLAGS_OPTIMIZE) +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. +COMPILE_DEBUG_FLAGS = +#COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG +#COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS + +SRC_DIR = @srcdir@ +ROOT_DIR = @srcdir@/.. +TOP_DIR = $(shell cd @srcdir@/..; pwd -P) +GENERIC_DIR = $(TOP_DIR)/generic +TOMMATH_DIR = $(TOP_DIR)/libtommath +WIN_DIR = $(TOP_DIR)/win +COMPAT_DIR = $(TOP_DIR)/compat +PKGS_DIR = $(TOP_DIR)/pkgs +ZLIB_DIR = $(COMPAT_DIR)/zlib + +# Converts a POSIX path to a Windows native path. +CYGPATH = @CYGPATH@ + +libdir_native = $(shell $(CYGPATH) '$(libdir)') +bindir_native = $(shell $(CYGPATH) '$(bindir)') +includedir_native = $(shell $(CYGPATH) '$(includedir)') +mandir_native = $(shell $(CYGPATH) '$(mandir)') +TCL_LIBRARY_NATIVE = $(shell $(CYGPATH) '$(TCL_LIBRARY)') +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) +#ROOT_DIR_NATIVE = $(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 -P) +LIBRARY_DIR = $(shell $(CYGPATH) '$(LIBRARY_DIR1)') +DLLSUFFIX = @DLLSUFFIX@ +LIBSUFFIX = @LIBSUFFIX@ +EXESUFFIX = @EXESUFFIX@ + +VER = @TCL_MAJOR_VERSION@@TCL_MINOR_VERSION@ +DOTVER = @TCL_MAJOR_VERSION@.@TCL_MINOR_VERSION@ +DDEVER = @TCL_DDE_MAJOR_VERSION@@TCL_DDE_MINOR_VERSION@ +DDEDOTVER = @TCL_DDE_MAJOR_VERSION@.@TCL_DDE_MINOR_VERSION@ +REGVER = @TCL_REG_MAJOR_VERSION@@TCL_REG_MINOR_VERSION@ +REGDOTVER = @TCL_REG_MAJOR_VERSION@.@TCL_REG_MINOR_VERSION@ + +TCL_STUB_LIB_FILE = @TCL_STUB_LIB_FILE@ +TCL_DLL_FILE = @TCL_DLL_FILE@ +TCL_LIB_FILE = @TCL_LIB_FILE@ +DDE_DLL_FILE = tcldde$(DDEVER)${DLLSUFFIX} +DDE_LIB_FILE = @LIBPREFIX@tcldde$(DDEVER)${LIBSUFFIX} +REG_DLL_FILE = tclreg$(REGVER)${DLLSUFFIX} +REG_LIB_FILE = @LIBPREFIX@tclreg$(REGVER)${LIBSUFFIX} +TEST_DLL_FILE = tcltest$(VER)${DLLSUFFIX} +TEST_LIB_FILE = @LIBPREFIX@tcltest$(VER)${LIBSUFFIX} +ZLIB_DLL_FILE = zlib1.dll + +SHARED_LIBRARIES = $(TCL_DLL_FILE) @ZLIB_DLL_FILE@ +STATIC_LIBRARIES = $(TCL_LIB_FILE) + +TCLSH = tclsh$(VER)${EXESUFFIX} +CAT32 = cat32$(EXEEXT) +MAN2TCL = man2tcl$(EXEEXT) + +# For cross-compiled builds, TCL_EXE is the name of a tclsh executable that is +# available *BEFORE* running make for the first time. Certain build targets +# (make genstubs, make install) need it to be available on the PATH. This +# executable should *NOT* be required just to do a normal build although +# it can be required to run make dist. +TCL_EXE = @TCL_EXE@ + +@SET_MAKE@ + +# Setting the VPATH variable to a list of paths will cause the Makefile to +# look into these paths when resolving .c to .obj dependencies. + +VPATH = $(GENERIC_DIR):$(TOMMATH_DIR):$(WIN_DIR):$(COMPAT_DIR):$(ZLIB_DIR) + +AR = @AR@ +RANLIB = @RANLIB@ +CC = @CC@ +RC = @RC@ +RES = @RES@ +AC_FLAGS = @EXTRA_CFLAGS@ @DEFS@ +CPPFLAGS = @CPPFLAGS@ +LDFLAGS_DEBUG = @LDFLAGS_DEBUG@ +LDFLAGS_OPTIMIZE = @LDFLAGS_OPTIMIZE@ +LDFLAGS = @LDFLAGS@ @LDFLAGS_DEFAULT@ +LDFLAGS_CONSOLE = @LDFLAGS_CONSOLE@ +LDFLAGS_WINDOW = @LDFLAGS_WINDOW@ +EXEEXT = @EXEEXT@ +OBJEXT = @OBJEXT@ +STLIB_LD = @STLIB_LD@ +SHLIB_LD = @SHLIB_LD@ +SHLIB_LD_LIBS = @SHLIB_LD_LIBS@ +SHLIB_CFLAGS = @SHLIB_CFLAGS@ +SHLIB_SUFFIX = @SHLIB_SUFFIX@ +LIBS = @LIBS@ $(shell $(CYGPATH) '@ZLIB_LIBS@') + +RMDIR = rm -rf +MKDIR = mkdir -p +SHELL = @SHELL@ +RM = rm -f +COPY = cp + +CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${TCL_SHLIB_CFLAGS} \ +-I"${ZLIB_DIR_NATIVE}" -I"${GENERIC_DIR_NATIVE}" \ +-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@ + +STUB_CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \ +-I"${GENERIC_DIR_NATIVE}" -DMP_PREC=4 -I"${TOMMATH_DIR_NATIVE}" \ +-I"${WIN_DIR_NATIVE}" ${AC_FLAGS} \ +${COMPILE_DEBUG_FLAGS} + +TCLTEST_OBJS = \ + tclTest.$(OBJEXT) \ + tclTestObj.$(OBJEXT) \ + tclTestProcBodyObj.$(OBJEXT) \ + tclThreadTest.$(OBJEXT) \ + tclWinTest.$(OBJEXT) + +GENERIC_OBJS = \ + regcomp.$(OBJEXT) \ + regexec.$(OBJEXT) \ + regfree.$(OBJEXT) \ + regerror.$(OBJEXT) \ + tclAlloc.$(OBJEXT) \ + tclAssembly.$(OBJEXT) \ + tclAsync.$(OBJEXT) \ + tclBasic.$(OBJEXT) \ + tclBinary.$(OBJEXT) \ + tclCkalloc.$(OBJEXT) \ + tclClock.$(OBJEXT) \ + tclCmdAH.$(OBJEXT) \ + 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) \ + tclFCmd.$(OBJEXT) \ + tclFileName.$(OBJEXT) \ + tclGet.$(OBJEXT) \ + tclHash.$(OBJEXT) \ + tclHistory.$(OBJEXT) \ + tclIndexObj.$(OBJEXT) \ + tclInterp.$(OBJEXT) \ + tclIO.$(OBJEXT) \ + tclIOCmd.$(OBJEXT) \ + tclIOGT.$(OBJEXT) \ + tclIORChan.$(OBJEXT) \ + tclIORTrans.$(OBJEXT) \ + tclIOSock.$(OBJEXT) \ + tclIOUtil.$(OBJEXT) \ + tclLink.$(OBJEXT) \ + tclLiteral.$(OBJEXT) \ + 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) \ + tclPipe.$(OBJEXT) \ + tclPkg.$(OBJEXT) \ + tclPkgConfig.$(OBJEXT) \ + tclPosixStr.$(OBJEXT) \ + tclPreserve.$(OBJEXT) \ + tclProc.$(OBJEXT) \ + tclRegexp.$(OBJEXT) \ + tclResolve.$(OBJEXT) \ + tclResult.$(OBJEXT) \ + tclScan.$(OBJEXT) \ + tclStringObj.$(OBJEXT) \ + tclStrToD.$(OBJEXT) \ + tclStubInit.$(OBJEXT) \ + tclThread.$(OBJEXT) \ + tclThreadAlloc.$(OBJEXT) \ + tclThreadJoin.$(OBJEXT) \ + tclThreadStorage.$(OBJEXT) \ + tclTimer.$(OBJEXT) \ + tclTomMathInterface.$(OBJEXT) \ + tclTrace.$(OBJEXT) \ + tclUtf.$(OBJEXT) \ + tclUtil.$(OBJEXT) \ + tclVar.$(OBJEXT) \ + tclZlib.$(OBJEXT) + +TOMMATH_OBJS = \ + bncore.${OBJEXT} \ + bn_reverse.${OBJEXT} \ + bn_fast_s_mp_mul_digs.${OBJEXT} \ + bn_fast_s_mp_sqr.${OBJEXT} \ + bn_mp_add.${OBJEXT} \ + bn_mp_add_d.${OBJEXT} \ + bn_mp_and.${OBJEXT} \ + bn_mp_clamp.${OBJEXT} \ + bn_mp_clear.${OBJEXT} \ + bn_mp_clear_multi.${OBJEXT} \ + bn_mp_cmp.${OBJEXT} \ + bn_mp_cmp_d.${OBJEXT} \ + bn_mp_cmp_mag.${OBJEXT} \ + bn_mp_cnt_lsb.${OBJEXT} \ + bn_mp_copy.${OBJEXT} \ + bn_mp_count_bits.${OBJEXT} \ + bn_mp_div.${OBJEXT} \ + bn_mp_div_d.${OBJEXT} \ + bn_mp_div_2.${OBJEXT} \ + bn_mp_div_2d.${OBJEXT} \ + bn_mp_div_3.${OBJEXT} \ + bn_mp_exch.${OBJEXT} \ + bn_mp_expt_d.${OBJEXT} \ + bn_mp_expt_d_ex.${OBJEXT} \ + bn_mp_get_int.${OBJEXT} \ + bn_mp_get_long.${OBJEXT} \ + bn_mp_get_long_long.${OBJEXT} \ + bn_mp_grow.${OBJEXT} \ + bn_mp_init.${OBJEXT} \ + bn_mp_init_copy.${OBJEXT} \ + bn_mp_init_multi.${OBJEXT} \ + bn_mp_init_set.${OBJEXT} \ + bn_mp_init_set_int.${OBJEXT} \ + bn_mp_init_size.${OBJEXT} \ + bn_mp_karatsuba_mul.${OBJEXT} \ + bn_mp_karatsuba_sqr.$(OBJEXT) \ + bn_mp_lshd.${OBJEXT} \ + bn_mp_mod.${OBJEXT} \ + bn_mp_mod_2d.${OBJEXT} \ + bn_mp_mul.${OBJEXT} \ + bn_mp_mul_2.${OBJEXT} \ + bn_mp_mul_2d.${OBJEXT} \ + bn_mp_mul_d.${OBJEXT} \ + bn_mp_neg.${OBJEXT} \ + bn_mp_or.${OBJEXT} \ + bn_mp_radix_size.${OBJEXT} \ + bn_mp_radix_smap.${OBJEXT} \ + bn_mp_read_radix.${OBJEXT} \ + bn_mp_rshd.${OBJEXT} \ + bn_mp_set.${OBJEXT} \ + bn_mp_set_int.${OBJEXT} \ + bn_mp_set_long.${OBJEXT} \ + bn_mp_set_long_long.${OBJEXT} \ + bn_mp_shrink.${OBJEXT} \ + bn_mp_sqr.${OBJEXT} \ + bn_mp_sqrt.${OBJEXT} \ + bn_mp_sub.${OBJEXT} \ + bn_mp_sub_d.${OBJEXT} \ + bn_mp_to_unsigned_bin.${OBJEXT} \ + bn_mp_to_unsigned_bin_n.${OBJEXT} \ + bn_mp_toom_mul.${OBJEXT} \ + bn_mp_toom_sqr.${OBJEXT} \ + bn_mp_toradix_n.${OBJEXT} \ + bn_mp_unsigned_bin_size.${OBJEXT} \ + bn_mp_xor.${OBJEXT} \ + bn_mp_zero.${OBJEXT} \ + bn_s_mp_add.${OBJEXT} \ + bn_s_mp_mul_digs.${OBJEXT} \ + bn_s_mp_sqr.${OBJEXT} \ + bn_s_mp_sub.${OBJEXT} + + +WIN_OBJS = \ + tclWin32Dll.$(OBJEXT) \ + tclWinChan.$(OBJEXT) \ + tclWinConsole.$(OBJEXT) \ + tclWinSerial.$(OBJEXT) \ + tclWinError.$(OBJEXT) \ + tclWinFCmd.$(OBJEXT) \ + tclWinFile.$(OBJEXT) \ + tclWinInit.$(OBJEXT) \ + tclWinLoad.$(OBJEXT) \ + tclWinNotify.$(OBJEXT) \ + tclWinPipe.$(OBJEXT) \ + tclWinSock.$(OBJEXT) \ + tclWinThrd.$(OBJEXT) \ + tclWinTime.$(OBJEXT) + +DDE_OBJS = tclWinDde.$(OBJEXT) + +REG_OBJS = tclWinReg.$(OBJEXT) + +STUB_OBJS = \ + tclStubLib.$(OBJEXT) \ + tclTomMathStubLib.$(OBJEXT) \ + tclOOStubLib.$(OBJEXT) + +TCLSH_OBJS = tclAppInit.$(OBJEXT) + +ZLIB_OBJS = \ + adler32.$(OBJEXT) \ + compress.$(OBJEXT) \ + crc32.$(OBJEXT) \ + deflate.$(OBJEXT) \ + infback.$(OBJEXT) \ + inffast.$(OBJEXT) \ + inflate.$(OBJEXT) \ + inftrees.$(OBJEXT) \ + trees.$(OBJEXT) \ + uncompr.$(OBJEXT) \ + zutil.$(OBJEXT) + +TCL_OBJS = ${GENERIC_OBJS} $(TOMMATH_OBJS) ${WIN_OBJS} @ZLIB_OBJS@ + +TCL_DOCS = "$(ROOT_DIR_NATIVE)"/doc/*.[13n] + +all: binaries libraries doc packages + +tcltest: $(TCLSH) $(TEST_DLL_FILE) + +binaries: $(TCL_STUB_LIB_FILE) @LIBRARIES@ winextensions $(TCLSH) + +winextensions: ${DDE_DLL_FILE} ${REG_DLL_FILE} + +libraries: + +doc: + +$(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@ + +cat32.$(OBJEXT): cat.c + $(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME) + +$(CAT32): cat32.$(OBJEXT) + $(CC) $(CFLAGS) cat32.$(OBJEXT) $(CC_EXENAME) $(LIBS) $(LDFLAGS_CONSOLE) + +# The following targets are configured by autoconf to generate either a shared +# library or static library + +${TCL_STUB_LIB_FILE}: ${STUB_OBJS} + @$(RM) ${TCL_STUB_LIB_FILE} + @MAKE_STUB_LIB@ ${STUB_OBJS} + @POST_MAKE_LIB@ + +${TCL_DLL_FILE}: ${TCL_OBJS} tcl.$(RES) @ZLIB_DLL_FILE@ + @$(RM) ${TCL_DLL_FILE} $(TCL_LIB_FILE) + @MAKE_DLL@ ${TCL_OBJS} tcl.$(RES) $(SHLIB_LD_LIBS) + @VC_MANIFEST_EMBED_DLL@ + +${TCL_LIB_FILE}: ${TCL_OBJS} ${DDE_OBJS} ${REG_OBJS} + @$(RM) ${TCL_LIB_FILE} + @MAKE_LIB@ ${TCL_OBJS} ${DDE_OBJS} ${REG_OBJS} + @POST_MAKE_LIB@ + +${DDE_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${DDE_OBJS} + @MAKE_DLL@ ${DDE_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) + +${REG_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${REG_OBJS} + @MAKE_DLL@ ${REG_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) + +${TEST_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${TCLTEST_OBJS} + @$(RM) ${TEST_DLL_FILE} ${TEST_LIB_FILE} + @MAKE_DLL@ ${TCLTEST_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) + +# 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. + +.SUFFIXES: .${OBJEXT} +.SUFFIXES: .$(RES) +.SUFFIXES: .rc + +# Special case object targets + +tclWinInit.${OBJEXT}: tclWinInit.c + $(CC) -c $(CC_SWITCHES) -DBUILD_tcl $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME) + +tclWinPipe.${OBJEXT}: tclWinPipe.c + $(CC) -c $(CC_SWITCHES) -DBUILD_tcl $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME) + +testMain.${OBJEXT}: tclAppInit.c + $(CC) -c $(CC_SWITCHES) -DTCL_TEST @DEPARG@ $(CC_OBJNAME) + +tclMain2.${OBJEXT}: tclMain.c + $(CC) -c $(CC_SWITCHES) -DBUILD_tcl -DTCL_ASCII_MAIN @DEPARG@ $(CC_OBJNAME) + +# TIP #59, embedding of configuration information into the binary library. +# +# Part of Tcl's configuration information are the paths where it was installed +# and where it will look for its libraries (which can be different). We derive +# this information from the variables which can be overridden by the user. As +# every path can be configured separately we do not remember one general +# prefix/exec_prefix but all the different paths individually. + +tclPkgConfig.${OBJEXT}: tclPkgConfig.c + $(CC) -c $(CC_SWITCHES) \ + -DCFG_INSTALL_LIBDIR=\"$(LIB_INSTALL_DIR_NATIVE)\" \ + -DCFG_INSTALL_BINDIR=\"$(BIN_INSTALL_DIR_NATIVE)\" \ + -DCFG_INSTALL_SCRDIR=\"$(SCRIPT_INSTALL_DIR_NATIVE)\" \ + -DCFG_INSTALL_INCDIR=\"$(INCLUDE_INSTALL_DIR_NATIVE)\" \ + -DCFG_INSTALL_DOCDIR=\"$(MAN_INSTALL_DIR)\" \ + \ + -DCFG_RUNTIME_LIBDIR=\"$(libdir_native)\" \ + -DCFG_RUNTIME_BINDIR=\"$(bindir_native)\" \ + -DCFG_RUNTIME_SCRDIR=\"$(TCL_LIBRARY_NATIVE)\" \ + -DCFG_RUNTIME_INCDIR=\"$(includedir_native)\" \ + -DCFG_RUNTIME_DOCDIR=\"$(mandir_native)\" \ + -DBUILD_tcl \ + @DEPARG@ $(CC_OBJNAME) + +# 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 + +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 + +%.${OBJEXT}: %.c + $(CC) -c $(CC_SWITCHES) -DBUILD_tcl @DEPARG@ $(CC_OBJNAME) + +.rc.$(RES): + $(RC) @RC_OUT@ $@ @RC_TYPE@ @RC_DEFINES@ @RC_INCLUDE@ "$(GENERIC_DIR_NATIVE)" @RC_INCLUDE@ "$(WIN_DIR_NATIVE)" @DEPARG@ + +# The following target generates the file generic/tclDate.c from the yacc +# grammar found in generic/tclGetDate.y. This is only run by hand as yacc is +# not available in all environments. The name of the .c file is different than +# the name of the .y file so that make doesn't try to automatically regenerate +# the .c file. + +gendate: + bison --output-file=$(GENERIC_DIR)/tclDate.c \ + --name-prefix=TclDate \ + --no-lines \ + $(GENERIC_DIR)/tclGetDate.y + +# The following target generates the file generic/tclTomMath.h. It needs to be +# 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" + +install: all install-binaries install-libraries install-doc install-packages + +install-binaries: binaries + @for i in "$(LIB_INSTALL_DIR)" "$(BIN_INSTALL_DIR)" ; \ + do \ + if [ ! -d $$i ] ; then \ + echo "Making directory $$i"; \ + $(MKDIR) $$i; \ + chmod 755 $$i; \ + else true; \ + fi; \ + done; + @for i in dde${DDEDOTVER} reg${REGDOTVER}; \ + do \ + if [ ! -d $(LIB_INSTALL_DIR)/$$i ] ; then \ + echo "Making directory $(LIB_INSTALL_DIR)/$$i"; \ + $(MKDIR) $(LIB_INSTALL_DIR)/$$i; \ + else true; \ + fi; \ + done; + @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 tclooConfig.sh $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE); \ + do \ + if [ -f $$i ]; then \ + echo "Installing $$i to $(LIB_INSTALL_DIR)/"; \ + $(COPY) $$i "$(LIB_INSTALL_DIR)"; \ + fi; \ + done + @if [ -f $(DDE_DLL_FILE) ]; then \ + echo Installing $(DDE_DLL_FILE); \ + $(COPY) $(DDE_DLL_FILE) $(LIB_INSTALL_DIR)/dde${DDEDOTVER}; \ + $(COPY) $(ROOT_DIR)/library/dde/pkgIndex.tcl \ + $(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}; \ + fi + @if [ -f $(REG_DLL_FILE) ]; then \ + echo Installing $(REG_DLL_FILE); \ + $(COPY) $(REG_DLL_FILE) $(LIB_INSTALL_DIR)/reg${REGDOTVER}; \ + $(COPY) $(ROOT_DIR)/library/reg/pkgIndex.tcl \ + $(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}; \ + fi + +install-libraries: libraries install-tzdata install-msgs + @for i in "$$($(CYGPATH) $(prefix)/lib)" "$(INCLUDE_INSTALL_DIR)" \ + $(SCRIPT_INSTALL_DIR); \ + do \ + if [ ! -d $$i ] ; then \ + echo "Making directory $$i"; \ + $(MKDIR) $$i; \ + else true; \ + fi; \ + done; + @for i in http1.0 opt0.4 encoding ../tcl8 ../tcl8/8.4 ../tcl8/8.4/platform ../tcl8/8.5 ../tcl8/8.6; \ + do \ + if [ ! -d $(SCRIPT_INSTALL_DIR)/$$i ] ; then \ + echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ + $(MKDIR) $(SCRIPT_INSTALL_DIR)/$$i; \ + else true; \ + fi; \ + 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"; \ + do \ + $(COPY) "$$i" "$(INCLUDE_INSTALL_DIR)"; \ + done; + @echo "Installing library files to $(SCRIPT_INSTALL_DIR)"; + @for i in $(ROOT_DIR)/library/*.tcl $(ROOT_DIR)/library/tclIndex; \ + do \ + $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)"; \ + done; + @echo "Installing library http1.0 directory"; + @for j in $(ROOT_DIR)/library/http1.0/*.tcl; \ + do \ + $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \ + done; + @echo "Installing package http 2.8.12 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.8.12.tm; + @echo "Installing library opt0.4 directory"; + @for j in $(ROOT_DIR)/library/opt/*.tcl; \ + do \ + $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \ + done; + @echo "Installing package msgcat 1.6.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.4.0 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.4.0.tm; + @echo "Installing package platform 1.0.14 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.14.tm; + @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/platform/shell.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform/shell-1.1.4.tm; + @echo "Installing encodings"; + @for i in $(ROOT_DIR)/library/encoding/*.enc ; do \ + $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)/encoding"; \ + done; + +install-tzdata: + @echo "Installing time zone data" + @$(TCL_EXE) "$(ROOT_DIR)/tools/installData.tcl" \ + "$(ROOT_DIR)/library/tzdata" "$(SCRIPT_INSTALL_DIR)/tzdata" + +install-msgs: + @echo "Installing message catalogs" + @$(TCL_EXE) "$(ROOT_DIR)/tools/installData.tcl" \ + "$(ROOT_DIR)/library/msgs" "$(SCRIPT_INSTALL_DIR)/msgs" + +install-doc: doc + +# Optional target to install private headers +install-private-headers: libraries + @for i in $(PRIVATE_INCLUDE_INSTALL_DIR); \ + do \ + if [ ! -d $$i ] ; then \ + echo "Making directory $$i"; \ + $(MKDIR) $$i; \ + else true; \ + fi; \ + done; + @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)"; \ + done; + +# Specifying TESTFLAGS on the command line is the standard way to pass args to +# tcltest, i.e.: +# % make test TESTFLAGS="-verbose bps -file fileName.test" + +test: test-tcl test-packages + +test-tcl: binaries $(TCLSH) $(CAT32) $(TEST_DLL_FILE) + TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ + ./$(TCLSH) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \ + -load "package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest]; \ + package ifneeded dde 1.4.0 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ + package ifneeded registry 1.3.2 [list load [file normalize ${REG_DLL_FILE}] registry]" | ./$(CAT32) + +# Useful target to launch a built tclsh with the proper path,... +runtest: binaries $(TCLSH) $(TEST_DLL_FILE) + @TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ + ./$(TCLSH) $(TESTFLAGS) -load "package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest]; \ + package ifneeded dde 1.4.0 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ + package ifneeded registry 1.3.2 [list load [file normalize ${REG_DLL_FILE}] registry]" $(SCRIPT) + +# This target can be used to run tclsh from the build directory via +# `make shell SCRIPT=foo.tcl` +shell: binaries + @TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ + ./$(TCLSH) $(SCRIPT) + +# This target can be used to run tclsh inside either gdb or insight +gdb: binaries + @echo "set env TCL_LIBRARY=$(LIBRARY_DIR)" > gdb.run + gdb ./$(TCLSH) --command=gdb.run + rm gdb.run + +depend: + +Makefile: $(SRC_DIR)/Makefile.in + ./config.status + +cleanhelp: + $(RM) *.hlp *.cnt *.GID *.rtf man2tcl.exe + +clean: cleanhelp clean-packages + $(RM) *.lib *.a *.exp *.dll *.$(RES) *.${OBJEXT} *~ \#* TAGS a.out + $(RM) $(TCLSH) $(CAT32) + $(RM) *.pch *.ilk *.pdb + +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. +# + +$(GENERIC_DIR)/tclStubInit.c: $(GENERIC_DIR)/tcl.decls \ + $(GENERIC_DIR)/tclInt.decls + @echo "Warning: tclStubInit.c may be out of date." + @echo "Developers may want to run \"make genstubs\" to regenerate." + @echo "This warning can be safely ignored, do not report as a bug!" + +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)/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 +# 'make' from getting confused when someone makes an error in a rule. +# + +.PHONY: all tcltest binaries libraries doc gendate gentommath_h install +.PHONY: install-binaries install-libraries install-tzdata install-msgs +.PHONY: install-doc install-private-headers test test-tcl runtest shell +.PHONY: gdb depend cleanhelp clean distclean packages install-packages +.PHONY: test-packages clean-packages distclean-packages genstubs html +.PHONY: html-tcl html-tk + +# DO NOT DELETE THIS LINE -- make depend depends on it. diff --git a/win/README b/win/README new file mode 100644 index 0000000..972923c --- /dev/null +++ b/win/README @@ -0,0 +1,99 @@ +Tcl 8.7 for Windows + +1. Introduction +--------------- + +This is the directory where you configure and compile the Windows +version of Tcl. This directory also contains source files for Tcl +that are specific to Microsoft Windows. + +The information in this file is maintained on the web at: + + http://www.tcl.tk/doc/howto/compile.html#win + +2. Compiling Tcl +---------------- + +In order to compile Tcl for Windows, you need the following: + + Tcl 8.7 Source Distribution (plus any patches) + + and + + Visual C++ 6 or newer + + or + + Linux + MinGW-w64 [http://mingw-w64.sourceforge.net/] + (win32 or win64) + + or + + Cygwin + MinGW-w64 [http://cygwin.com/install.html] + (win32 or win64) + + or + + Darwin + MinGW-w64 [http://mingw-w64.sourceforge.net/] + (win32 or win64) + + or + + Msys + MinGW-w64 [http://mingw-w64.sourceforge.net/] + (win32 or win64) + + or + + Msys + MinGW [http://www.mingw.org/download.shtml] + (win32 only) + + +In practice, this release is built with Visual C++ 6.0 and the TEA +Makefile. + +If you are building with Visual C++, in the "win" subdirectory of the +source release, you will find "makefile.vc". This is the makefile for the +Visual C++ compiler and uses the stock NMAKE tool. Detailed directions for +using it, are in the comments of "makefile.vc". A quick example would be: + + C:\tcl_source\win\>nmake -f makefile.vc + +There is also a Developer Studio workspace and project file, too, if you +would like to use them. + +If you are building with Linux, Cygwin or Msys, you can use the configure +script that lives in the win subdirectory. The Linux/Cygwin/Msys based +configure/build process works just like the UNIX one, so you will want +to refer to ../unix/README for available configure options. + +If you want 64-bit executables (x86_64), you need to configure using +the --enable-64bit option. Make sure that the x86_64-w64-mingw32 +compiler is present. For Cygwin this compiler can be found in the +"mingw64-x86_64-gcc-core" package, which can be installed through +the normal Cygwin install process. If you only want 32-bit executables, +the "mingw64-i686-gcc-core" package is what you need. For Linux, Darwin +and Msys, you can download a suitable win32 or win64 compiler from +[https://sourceforge.net/projects/mingw-w64/files/] + +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 tclsh87.exe, you must ensure that tcl87.dll is +on your path, in the system directory, or in the directory containing +tclsh87.exe. + +Note: Tcl no longer provides support for Win32s. + +3. Test suite +------------- + +This distribution contains an extensive test suite for Tcl. Some of the +tests are timing dependent and will fail from time to time. If a test is +failing consistently, please send us a bug report with as much detail as +you can manage to our tracker: + + http://core.tcl.tk/tcl/reportlist + +In order to run the test suite, you build the "test" target using the +appropriate makefile for your compiler. diff --git a/win/aclocal.m4 b/win/aclocal.m4 new file mode 100644 index 0000000..bc7540d --- /dev/null +++ b/win/aclocal.m4 @@ -0,0 +1 @@ +builtin(include,tcl.m4) diff --git a/win/buildall.vc.bat b/win/buildall.vc.bat new file mode 100644 index 0000000..deb9e39 --- /dev/null +++ b/win/buildall.vc.bat @@ -0,0 +1,103 @@ +@echo off
+
+:: This is an example batchfile for building everything. Please
+:: edit this (or make your own) for your needs and wants using
+:: the instructions for calling makefile.vc found in makefile.vc
+
+set SYMBOLS=
+
+:OPTIONS
+if "%1" == "/?" goto help
+if /i "%1" == "/help" goto help
+if %1.==symbols. goto SYMBOLS
+if %1.==debug. goto SYMBOLS
+goto OPTIONS_DONE
+
+:SYMBOLS
+ set SYMBOLS=symbols
+ shift
+ goto OPTIONS
+
+:OPTIONS_DONE
+
+:: reset errorlevel
+cd > nul
+
+:: You might have installed your developer studio to add itself to the
+:: path or have already run vcvars32.bat. Testing these envars proves
+:: cl.exe and friends are in your path.
+::
+if defined VCINSTALLDIR (goto :startBuilding)
+if defined MSDEVDIR (goto :startBuilding)
+if defined MSVCDIR (goto :startBuilding)
+if defined MSSDK (goto :startBuilding)
+if defined WINDOWSSDKDIR (goto :startBuilding)
+
+:: We need to run the development environment batch script that comes
+:: with developer studio (v4,5,6,7,etc...) All have it. This path
+:: might not be correct. You should call it yourself prior to running
+:: this batchfile.
+::
+call "C:\Program Files\Microsoft Developer Studio\vc98\bin\vcvars32.bat"
+if errorlevel 1 (goto no_vcvars)
+
+:startBuilding
+
+echo.
+echo Sit back and have a cup of coffee while this grinds through ;)
+echo You asked for *everything*, remember?
+echo.
+title Building Tcl, please wait...
+
+
+:: makefile.vc uses this for its default anyways, but show its use here
+:: just to be explicit and convey understanding to the user. Setting
+:: the INSTALLDIR envar prior to running this batchfile affects all builds.
+::
+if "%INSTALLDIR%" == "" set INSTALLDIR=C:\Program Files\Tcl
+
+
+:: Build the normal stuff along with the help file.
+::
+set OPTS=none
+if not %SYMBOLS%.==. set OPTS=symbols
+nmake -nologo -f makefile.vc release htmlhelp OPTS=%OPTS% %1
+if errorlevel 1 goto error
+
+:: Build the static core and shell.
+::
+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
+
+set OPTS=
+set SYMBOLS=
+goto end
+
+:error
+echo *** BOOM! ***
+goto end
+
+:no_vcvars
+echo vcvars32.bat was not run prior to this batchfile, nor are the MS tools in your path.
+goto out
+
+:help
+title buildall.vc.bat help message
+echo usage:
+echo %0 : builds Tcl for all build types (do this first)
+echo %0 install : installs all the release builds (do this second)
+echo %0 symbols : builds Tcl for all debugging build types
+echo %0 symbols install : install all the debug builds.
+echo.
+goto out
+
+:end
+title Building Tcl, please wait... DONE!
+echo DONE!
+goto out
+
+:out
+pause
+title Command Prompt
diff --git a/win/cat.c b/win/cat.c new file mode 100644 index 0000000..d49e37c --- /dev/null +++ b/win/cat.c @@ -0,0 +1,41 @@ +/* + * cat.c -- + * + * Program used when testing tclWinPipe.c + * + * 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. + */ + +#ifdef TCL_BROKEN_MAINARGS +/* On mingw32 and cygwin this doesn't work */ +# undef UNICODE +# undef _UNICODE +#endif + +#include <stdio.h> +#include <io.h> +#include <string.h> +#include <tchar.h> + +int +_tmain(void) +{ + char buf[1024]; + int n; + const char *err; + + while (1) { + n = read(0, buf, sizeof(buf)); + if (n <= 0) { + break; + } + write(1, buf, n); + } + err = (sizeof(int) == 2) ? "stderr16" : "stderr32"; + write(2, err, strlen(err)); + + return 0; +} diff --git a/win/coffbase.txt b/win/coffbase.txt new file mode 100644 index 0000000..3314f26 --- /dev/null +++ b/win/coffbase.txt @@ -0,0 +1,43 @@ +;
+; This file defines the virtual base addresses for the Dynamic Link Libraries
+; that are part of the Tcl system. The first token on a line is the key (or name
+; of the DLL) and the second token is the virtual base address, in hexidecimal.
+; The third token is the maximum size of the DLL image file, including symbols.
+;
+; Using a specified "prefered load address" should speed loading time by avoiding
+; relocations (NT supported only). It is assumed extension authors will contribute
+; their modules to this grand-master list. You can use the dumpbin utility with
+; the /headers option to get the "size of image" data (already in hex). If the
+; maximum size is too small a linker warning will occur. Modules can overlap when
+; they're mutually exclusive. This info is placed in the DLL's PE header by the
+; linker with the `-base:@$(TCLDIR)\win\coffbase.txt,<key>` option.
+
+tcl 0x10000000 0x00200000
+tcldde 0x10200000 0x00010000
+tclreg 0x10210000 0x00010000
+tk 0x10220000 0x00200000
+expect 0x10480000 0x00080000
+itcl 0x10500000 0x00080000
+itk 0x10580000 0x00080000
+bltlite 0x10600000 0x00080000
+blt 0x10680000 0x00080000
+iocpsock 0x10700000 0x00080000
+tls 0x10780000 0x00100000
+winico 0x10880000 0x00010000
+sample 0x108B0000 0x00010000
+tile 0x10900000 0x00080000
+memchan 0x109D0000 0x00010000
+tdom 0x109E0000 0x00080000
+tclvfs 0x10A70000 0x00010000
+tkvideo 0x10B00000 0x00010000
+tclsdl 0x10B20000 0x00080000
+vqtcl 0x10C00000 0x00010000
+tdbc 0x10C40000 0x00010000
+thread 0x10C80000 0x00020000
+nsf 0x10ca0000 0x00080000
+;
+; insert new packages here
+;
+snack 0x1E000000 0x00400000
+sound 0x1E400000 0x00400000
+snackogg 0x1E800000 0x00200000
diff --git a/win/configure b/win/configure new file mode 100755 index 0000000..fdd3adb --- /dev/null +++ b/win/configure @@ -0,0 +1,6465 @@ +#! /bin/sh +# Guess values for system-dependent variables and create Makefiles. +# Generated by GNU Autoconf 2.69. +# +# +# Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. +# +# +# This configure script is free software; the Free Software Foundation +# gives unlimited permission to copy, distribute and modify it. +## -------------------- ## +## M4sh Initialization. ## +## -------------------- ## + +# Be more Bourne compatible +DUALCASE=1; export DUALCASE # for MKS sh +if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : + emulate sh + NULLCMD=: + # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which + # is contrary to our usage. Disable this feature. + alias -g '${1+"$@"}'='"$@"' + setopt NO_GLOB_SUBST +else + case `(set -o) 2>/dev/null` in #( + *posix*) : + set -o posix ;; #( + *) : + ;; +esac +fi + + +as_nl=' +' +export as_nl +# Printing a long string crashes Solaris 7 /usr/bin/printf. +as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' +as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo +as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo +# Prefer a ksh shell builtin over an external printf program on Solaris, +# but without wasting forks for bash or zsh. +if test -z "$BASH_VERSION$ZSH_VERSION" \ + && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='print -r --' + as_echo_n='print -rn --' +elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='printf %s\n' + as_echo_n='printf %s' +else + if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then + as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' + as_echo_n='/usr/ucb/echo -n' + else + as_echo_body='eval expr "X$1" : "X\\(.*\\)"' + as_echo_n_body='eval + arg=$1; + case $arg in #( + *"$as_nl"*) + expr "X$arg" : "X\\(.*\\)$as_nl"; + arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; + esac; + expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" + ' + export as_echo_n_body + as_echo_n='sh -c $as_echo_n_body as_echo' + fi + export as_echo_body + as_echo='sh -c $as_echo_body as_echo' +fi + +# The user is always right. +if test "${PATH_SEPARATOR+set}" != set; then + PATH_SEPARATOR=: + (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { + (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || + PATH_SEPARATOR=';' + } +fi + + +# IFS +# We need space, tab and new line, in precisely that order. Quoting is +# there to prevent editors from complaining about space-tab. +# (If _AS_PATH_WALK were called with IFS unset, it would disable word +# splitting by setting IFS to empty value.) +IFS=" "" $as_nl" + +# Find who we are. Look in the path if we contain no directory separator. +as_myself= +case $0 in #(( + *[\\/]* ) as_myself=$0 ;; + *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break + done +IFS=$as_save_IFS + + ;; +esac +# We did not find ourselves, most probably we were run as `sh COMMAND' +# in which case we are not to be found in the path. +if test "x$as_myself" = x; then + as_myself=$0 +fi +if test ! -f "$as_myself"; then + $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 + exit 1 +fi + +# Unset variables that we do not need and which cause bugs (e.g. in +# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" +# suppresses any "Segmentation fault" message there. '((' could +# trigger a bug in pdksh 5.2.14. +for as_var in BASH_ENV ENV MAIL MAILPATH +do eval test x\${$as_var+set} = xset \ + && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : +done +PS1='$ ' +PS2='> ' +PS4='+ ' + +# NLS nuisances. +LC_ALL=C +export LC_ALL +LANGUAGE=C +export LANGUAGE + +# CDPATH. +(unset CDPATH) >/dev/null 2>&1 && unset CDPATH + +# Use a proper internal environment variable to ensure we don't fall + # into an infinite loop, continuously re-executing ourselves. + if test x"${_as_can_reexec}" != xno && test "x$CONFIG_SHELL" != x; then + _as_can_reexec=no; export _as_can_reexec; + # We cannot yet assume a decent shell, so we have to provide a +# neutralization value for shells without unset; and this also +# works around shells that cannot unset nonexistent variables. +# Preserve -v and -x to the replacement shell. +BASH_ENV=/dev/null +ENV=/dev/null +(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV +case $- in # (((( + *v*x* | *x*v* ) as_opts=-vx ;; + *v* ) as_opts=-v ;; + *x* ) as_opts=-x ;; + * ) as_opts= ;; +esac +exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} +# Admittedly, this is quite paranoid, since all the known shells bail +# out after a failed `exec'. +$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 +as_fn_exit 255 + fi + # We don't want this to propagate to other subprocesses. + { _as_can_reexec=; unset _as_can_reexec;} +if test "x$CONFIG_SHELL" = x; then + as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then : + emulate sh + NULLCMD=: + # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which + # is contrary to our usage. Disable this feature. + alias -g '\${1+\"\$@\"}'='\"\$@\"' + setopt NO_GLOB_SUBST +else + case \`(set -o) 2>/dev/null\` in #( + *posix*) : + set -o posix ;; #( + *) : + ;; +esac +fi +" + as_required="as_fn_return () { (exit \$1); } +as_fn_success () { as_fn_return 0; } +as_fn_failure () { as_fn_return 1; } +as_fn_ret_success () { return 0; } +as_fn_ret_failure () { return 1; } + +exitcode=0 +as_fn_success || { exitcode=1; echo as_fn_success failed.; } +as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; } +as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; } +as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; } +if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then : + +else + exitcode=1; echo positional parameters were not saved. +fi +test x\$exitcode = x0 || exit 1 +test -x / || exit 1" + as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO + as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO + eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" && + test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1 +test \$(( 1 + 1 )) = 2 || exit 1" + if (eval "$as_required") 2>/dev/null; then : + as_have_required=yes +else + as_have_required=no +fi + if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then : + +else + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +as_found=false +for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + as_found=: + case $as_dir in #( + /*) + for as_base in sh bash ksh sh5; do + # Try only shells that exist, to save several forks. + as_shell=$as_dir/$as_base + if { test -f "$as_shell" || test -f "$as_shell.exe"; } && + { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then : + CONFIG_SHELL=$as_shell as_have_required=yes + if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then : + break 2 +fi +fi + done;; + esac + as_found=false +done +$as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } && + { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then : + CONFIG_SHELL=$SHELL as_have_required=yes +fi; } +IFS=$as_save_IFS + + + if test "x$CONFIG_SHELL" != x; then : + export CONFIG_SHELL + # We cannot yet assume a decent shell, so we have to provide a +# neutralization value for shells without unset; and this also +# works around shells that cannot unset nonexistent variables. +# Preserve -v and -x to the replacement shell. +BASH_ENV=/dev/null +ENV=/dev/null +(unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV +case $- in # (((( + *v*x* | *x*v* ) as_opts=-vx ;; + *v* ) as_opts=-v ;; + *x* ) as_opts=-x ;; + * ) as_opts= ;; +esac +exec $CONFIG_SHELL $as_opts "$as_myself" ${1+"$@"} +# Admittedly, this is quite paranoid, since all the known shells bail +# out after a failed `exec'. +$as_echo "$0: could not re-execute with $CONFIG_SHELL" >&2 +exit 255 +fi + + if test x$as_have_required = xno; then : + $as_echo "$0: This script requires a shell more modern than all" + $as_echo "$0: the shells that I found on your system." + if test x${ZSH_VERSION+set} = xset ; then + $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should" + $as_echo "$0: be upgraded to zsh 4.3.4 or later." + else + $as_echo "$0: Please tell bug-autoconf@gnu.org about your system, +$0: including any error possibly output before this +$0: message. Then install a modern shell, or manually run +$0: the script under such a shell if you do have one." + fi + exit 1 +fi +fi +fi +SHELL=${CONFIG_SHELL-/bin/sh} +export SHELL +# Unset more variables known to interfere with behavior of common tools. +CLICOLOR_FORCE= GREP_OPTIONS= +unset CLICOLOR_FORCE GREP_OPTIONS + +## --------------------- ## +## M4sh Shell Functions. ## +## --------------------- ## +# as_fn_unset VAR +# --------------- +# Portably unset VAR. +as_fn_unset () +{ + { eval $1=; unset $1;} +} +as_unset=as_fn_unset + +# as_fn_set_status STATUS +# ----------------------- +# Set $? to STATUS, without forking. +as_fn_set_status () +{ + return $1 +} # as_fn_set_status + +# as_fn_exit STATUS +# ----------------- +# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. +as_fn_exit () +{ + set +e + as_fn_set_status $1 + exit $1 +} # as_fn_exit + +# as_fn_mkdir_p +# ------------- +# Create "$as_dir" as a directory, including parents if necessary. +as_fn_mkdir_p () +{ + + case $as_dir in #( + -*) as_dir=./$as_dir;; + esac + test -d "$as_dir" || eval $as_mkdir_p || { + as_dirs= + while :; do + case $as_dir in #( + *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( + *) as_qdir=$as_dir;; + esac + as_dirs="'$as_qdir' $as_dirs" + as_dir=`$as_dirname -- "$as_dir" || +$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$as_dir" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + test -d "$as_dir" && break + done + test -z "$as_dirs" || eval "mkdir $as_dirs" + } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" + + +} # as_fn_mkdir_p + +# as_fn_executable_p FILE +# ----------------------- +# Test if FILE is an executable regular file. +as_fn_executable_p () +{ + test -f "$1" && test -x "$1" +} # as_fn_executable_p +# as_fn_append VAR VALUE +# ---------------------- +# Append the text in VALUE to the end of the definition contained in VAR. Take +# advantage of any shell optimizations that allow amortized linear growth over +# repeated appends, instead of the typical quadratic growth present in naive +# implementations. +if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : + eval 'as_fn_append () + { + eval $1+=\$2 + }' +else + as_fn_append () + { + eval $1=\$$1\$2 + } +fi # as_fn_append + +# as_fn_arith ARG... +# ------------------ +# Perform arithmetic evaluation on the ARGs, and store the result in the +# global $as_val. Take advantage of shells that can avoid forks. The arguments +# must be portable across $(()) and expr. +if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : + eval 'as_fn_arith () + { + as_val=$(( $* )) + }' +else + as_fn_arith () + { + as_val=`expr "$@" || test $? -eq 1` + } +fi # as_fn_arith + + +# as_fn_error STATUS ERROR [LINENO LOG_FD] +# ---------------------------------------- +# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are +# provided, also output the error to LOG_FD, referencing LINENO. Then exit the +# script with STATUS, using 1 if that was 0. +as_fn_error () +{ + as_status=$1; test $as_status -eq 0 && as_status=1 + if test "$4"; then + as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 + fi + $as_echo "$as_me: error: $2" >&2 + as_fn_exit $as_status +} # as_fn_error + +if expr a : '\(a\)' >/dev/null 2>&1 && + test "X`expr 00001 : '.*\(...\)'`" = X001; then + as_expr=expr +else + as_expr=false +fi + +if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then + as_basename=basename +else + as_basename=false +fi + +if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then + as_dirname=dirname +else + as_dirname=false +fi + +as_me=`$as_basename -- "$0" || +$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ + X"$0" : 'X\(//\)$' \| \ + X"$0" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X/"$0" | + sed '/^.*\/\([^/][^/]*\)\/*$/{ + s//\1/ + q + } + /^X\/\(\/\/\)$/{ + s//\1/ + q + } + /^X\/\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + +# Avoid depending upon Character Ranges. +as_cr_letters='abcdefghijklmnopqrstuvwxyz' +as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' +as_cr_Letters=$as_cr_letters$as_cr_LETTERS +as_cr_digits='0123456789' +as_cr_alnum=$as_cr_Letters$as_cr_digits + + + as_lineno_1=$LINENO as_lineno_1a=$LINENO + as_lineno_2=$LINENO as_lineno_2a=$LINENO + eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" && + test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || { + # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-) + sed -n ' + p + /[$]LINENO/= + ' <$as_myself | + sed ' + s/[$]LINENO.*/&-/ + t lineno + b + :lineno + N + :loop + s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/ + t loop + s/-\n.*// + ' >$as_me.lineno && + chmod +x "$as_me.lineno" || + { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; } + + # If we had to re-execute with $CONFIG_SHELL, we're ensured to have + # already done that, so ensure we don't try to do so again and fall + # in an infinite loop. This has already happened in practice. + _as_can_reexec=no; export _as_can_reexec + # Don't try to exec as it changes $[0], causing all sort of problems + # (the dirname of $[0] is not the place where we might find the + # original and so on. Autoconf is especially sensitive to this). + . "./$as_me.lineno" + # Exit status is that of the last command. + exit +} + +ECHO_C= ECHO_N= ECHO_T= +case `echo -n x` in #((((( +-n*) + case `echo 'xy\c'` in + *c*) ECHO_T=' ';; # ECHO_T is single tab character. + xy) ECHO_C='\c';; + *) echo `echo ksh88 bug on AIX 6.1` > /dev/null + ECHO_T=' ';; + esac;; +*) + ECHO_N='-n';; +esac + +rm -f conf$$ conf$$.exe conf$$.file +if test -d conf$$.dir; then + rm -f conf$$.dir/conf$$.file +else + rm -f conf$$.dir + mkdir conf$$.dir 2>/dev/null +fi +if (echo >conf$$.file) 2>/dev/null; then + if ln -s conf$$.file conf$$ 2>/dev/null; then + as_ln_s='ln -s' + # ... but there are two gotchas: + # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. + # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. + # In both cases, we have to default to `cp -pR'. + ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || + as_ln_s='cp -pR' + elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln + else + as_ln_s='cp -pR' + fi +else + as_ln_s='cp -pR' +fi +rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file +rmdir conf$$.dir 2>/dev/null + +if mkdir -p . 2>/dev/null; then + as_mkdir_p='mkdir -p "$as_dir"' +else + test -d ./-p && rmdir ./-p + as_mkdir_p=false +fi + +as_test_x='test -x' +as_executable_p=as_fn_executable_p + +# Sed expression to map a string onto a valid CPP name. +as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" + +# Sed expression to map a string onto a valid variable name. +as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" + + +test -n "$DJDIR" || exec 7<&0 </dev/null +exec 6>&1 + +# Name of the host. +# hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, +# so uname gets run too. +ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` + +# +# Initializations. +# +ac_default_prefix=/usr/local +ac_clean_files= +ac_config_libobj_dir=. +LIBOBJS= +cross_compiling=no +subdirs= +MFLAGS= +MAKEFLAGS= + +# Identity of this package. +PACKAGE_NAME= +PACKAGE_TARNAME= +PACKAGE_VERSION= +PACKAGE_STRING= +PACKAGE_BUGREPORT= +PACKAGE_URL= + +ac_unique_file="../generic/tcl.h" +# Factoring default headers for most tests. +ac_includes_default="\ +#include <stdio.h> +#ifdef HAVE_SYS_TYPES_H +# include <sys/types.h> +#endif +#ifdef HAVE_SYS_STAT_H +# include <sys/stat.h> +#endif +#ifdef STDC_HEADERS +# include <stdlib.h> +# include <stddef.h> +#else +# ifdef HAVE_STDLIB_H +# include <stdlib.h> +# endif +#endif +#ifdef HAVE_STRING_H +# if !defined STDC_HEADERS && defined HAVE_MEMORY_H +# include <memory.h> +# endif +# include <string.h> +#endif +#ifdef HAVE_STRINGS_H +# include <strings.h> +#endif +#ifdef HAVE_INTTYPES_H +# include <inttypes.h> +#endif +#ifdef HAVE_STDINT_H +# include <stdint.h> +#endif +#ifdef HAVE_UNISTD_H +# include <unistd.h> +#endif" + +ac_subst_vars='LTLIBOBJS +LIBOBJS +RES +RC_DEFINES +RC_DEFINE +RC_INCLUDE +RC_TYPE +RC_OUT +TCL_REG_MINOR_VERSION +TCL_REG_MAJOR_VERSION +TCL_REG_VERSION +TCL_DDE_MINOR_VERSION +TCL_DDE_MAJOR_VERSION +TCL_DDE_VERSION +TCL_PACKAGE_PATH +TCL_LIB_VERSIONS_OK +TCL_EXP_FILE +TCL_BUILD_EXP_FILE +TCL_NEEDS_EXP_FILE +TCL_LD_SEARCH_FLAGS +TCL_CC_SEARCH_FLAGS +TCL_BUILD_LIB_SPEC +MAKE_EXE +MAKE_DLL +POST_MAKE_LIB +MAKE_STUB_LIB +MAKE_LIB +LIBRARIES +EXESUFFIX +LIBSUFFIX +LIBPREFIX +DLLSUFFIX +LIBS_GUI +TCL_SHARED_BUILD +SHLIB_SUFFIX +SHLIB_CFLAGS +SHLIB_LD_LIBS +SHLIB_LD +STLIB_LD +LDFLAGS_WINDOW +LDFLAGS_CONSOLE +LDFLAGS_OPTIMIZE +LDFLAGS_DEBUG +CC_EXENAME +CC_OBJNAME +DEPARG +EXTRA_CFLAGS +CFG_TCL_EXPORT_FILE_SUFFIX +CFG_TCL_UNSHARED_LIB_SUFFIX +CFG_TCL_SHARED_LIB_SUFFIX +TCL_DBGX +TCL_BIN_DIR +TCL_SRC_DIR +TCL_DLL_FILE +TCL_BUILD_STUB_LIB_PATH +TCL_BUILD_STUB_LIB_SPEC +TCL_INCLUDE_SPEC +TCL_STUB_LIB_PATH +TCL_STUB_LIB_SPEC +TCL_STUB_LIB_FLAG +TCL_STUB_LIB_FILE +TCL_LIB_SPEC +TCL_IMPORT_LIB_FLAG +TCL_IMPORT_LIB_FILE +TCL_STATIC_LIB_FLAG +TCL_STATIC_LIB_FILE +TCL_LIB_FLAG +TCL_LIB_FILE +TCL_EXE +PKG_CFG_ARGS +TCL_PATCH_LEVEL +TCL_MINOR_VERSION +TCL_MAJOR_VERSION +TCL_VERSION +MACHINE +TCL_WIN_VERSION +VC_MANIFEST_EMBED_EXE +VC_MANIFEST_EMBED_DLL +LDFLAGS_DEFAULT +CFLAGS_DEFAULT +ZLIB_OBJS +ZLIB_LIBS +ZLIB_DLL_FILE +CFLAGS_WARNING +CFLAGS_OPTIMIZE +CFLAGS_DEBUG +DL_LIBS +CELIB_DIR +CYGPATH +TCL_THREADS +SET_MAKE +RC +RANLIB +AR +EGREP +GREP +CPP +OBJEXT +EXEEXT +ac_ct_CC +CPPFLAGS +LDFLAGS +CFLAGS +CC +target_alias +host_alias +build_alias +LIBS +ECHO_T +ECHO_N +ECHO_C +DEFS +mandir +localedir +libdir +psdir +pdfdir +dvidir +htmldir +infodir +docdir +oldincludedir +includedir +localstatedir +sharedstatedir +sysconfdir +datadir +datarootdir +libexecdir +sbindir +bindir +program_transform_name +prefix +exec_prefix +PACKAGE_URL +PACKAGE_BUGREPORT +PACKAGE_STRING +PACKAGE_VERSION +PACKAGE_TARNAME +PACKAGE_NAME +PATH_SEPARATOR +SHELL' +ac_subst_files='' +ac_user_opts=' +enable_option_checking +enable_threads +with_encoding +enable_shared +enable_64bit +enable_wince +with_celib +enable_symbols +enable_embedded_manifest +' + ac_precious_vars='build_alias +host_alias +target_alias +CC +CFLAGS +LDFLAGS +LIBS +CPPFLAGS +CPP' + + +# Initialize some variables set by options. +ac_init_help= +ac_init_version=false +ac_unrecognized_opts= +ac_unrecognized_sep= +# The variables have the same names as the options, with +# dashes changed to underlines. +cache_file=/dev/null +exec_prefix=NONE +no_create= +no_recursion= +prefix=NONE +program_prefix=NONE +program_suffix=NONE +program_transform_name=s,x,x, +silent= +site= +srcdir= +verbose= +x_includes=NONE +x_libraries=NONE + +# Installation directory options. +# These are left unexpanded so users can "make install exec_prefix=/foo" +# and all the variables that are supposed to be based on exec_prefix +# by default will actually change. +# Use braces instead of parens because sh, perl, etc. also accept them. +# (The list follows the same order as the GNU Coding Standards.) +bindir='${exec_prefix}/bin' +sbindir='${exec_prefix}/sbin' +libexecdir='${exec_prefix}/libexec' +datarootdir='${prefix}/share' +datadir='${datarootdir}' +sysconfdir='${prefix}/etc' +sharedstatedir='${prefix}/com' +localstatedir='${prefix}/var' +includedir='${prefix}/include' +oldincludedir='/usr/include' +docdir='${datarootdir}/doc/${PACKAGE}' +infodir='${datarootdir}/info' +htmldir='${docdir}' +dvidir='${docdir}' +pdfdir='${docdir}' +psdir='${docdir}' +libdir='${exec_prefix}/lib' +localedir='${datarootdir}/locale' +mandir='${datarootdir}/man' + +ac_prev= +ac_dashdash= +for ac_option +do + # If the previous option needs an argument, assign it. + if test -n "$ac_prev"; then + eval $ac_prev=\$ac_option + ac_prev= + continue + fi + + case $ac_option in + *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; + *=) ac_optarg= ;; + *) ac_optarg=yes ;; + esac + + # Accept the important Cygnus configure options, so we can diagnose typos. + + case $ac_dashdash$ac_option in + --) + ac_dashdash=yes ;; + + -bindir | --bindir | --bindi | --bind | --bin | --bi) + ac_prev=bindir ;; + -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) + bindir=$ac_optarg ;; + + -build | --build | --buil | --bui | --bu) + ac_prev=build_alias ;; + -build=* | --build=* | --buil=* | --bui=* | --bu=*) + build_alias=$ac_optarg ;; + + -cache-file | --cache-file | --cache-fil | --cache-fi \ + | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) + ac_prev=cache_file ;; + -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ + | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) + cache_file=$ac_optarg ;; + + --config-cache | -C) + cache_file=config.cache ;; + + -datadir | --datadir | --datadi | --datad) + ac_prev=datadir ;; + -datadir=* | --datadir=* | --datadi=* | --datad=*) + datadir=$ac_optarg ;; + + -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \ + | --dataroo | --dataro | --datar) + ac_prev=datarootdir ;; + -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \ + | --dataroot=* | --dataroo=* | --dataro=* | --datar=*) + datarootdir=$ac_optarg ;; + + -disable-* | --disable-*) + ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid feature name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"enable_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval enable_$ac_useropt=no ;; + + -docdir | --docdir | --docdi | --doc | --do) + ac_prev=docdir ;; + -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*) + docdir=$ac_optarg ;; + + -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv) + ac_prev=dvidir ;; + -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*) + dvidir=$ac_optarg ;; + + -enable-* | --enable-*) + ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid feature name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"enable_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval enable_$ac_useropt=\$ac_optarg ;; + + -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ + | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ + | --exec | --exe | --ex) + ac_prev=exec_prefix ;; + -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ + | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ + | --exec=* | --exe=* | --ex=*) + exec_prefix=$ac_optarg ;; + + -gas | --gas | --ga | --g) + # Obsolete; use --with-gas. + with_gas=yes ;; + + -help | --help | --hel | --he | -h) + ac_init_help=long ;; + -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) + ac_init_help=recursive ;; + -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) + ac_init_help=short ;; + + -host | --host | --hos | --ho) + ac_prev=host_alias ;; + -host=* | --host=* | --hos=* | --ho=*) + host_alias=$ac_optarg ;; + + -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht) + ac_prev=htmldir ;; + -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \ + | --ht=*) + htmldir=$ac_optarg ;; + + -includedir | --includedir | --includedi | --included | --include \ + | --includ | --inclu | --incl | --inc) + ac_prev=includedir ;; + -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ + | --includ=* | --inclu=* | --incl=* | --inc=*) + includedir=$ac_optarg ;; + + -infodir | --infodir | --infodi | --infod | --info | --inf) + ac_prev=infodir ;; + -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) + infodir=$ac_optarg ;; + + -libdir | --libdir | --libdi | --libd) + ac_prev=libdir ;; + -libdir=* | --libdir=* | --libdi=* | --libd=*) + libdir=$ac_optarg ;; + + -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ + | --libexe | --libex | --libe) + ac_prev=libexecdir ;; + -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ + | --libexe=* | --libex=* | --libe=*) + libexecdir=$ac_optarg ;; + + -localedir | --localedir | --localedi | --localed | --locale) + ac_prev=localedir ;; + -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*) + localedir=$ac_optarg ;; + + -localstatedir | --localstatedir | --localstatedi | --localstated \ + | --localstate | --localstat | --localsta | --localst | --locals) + ac_prev=localstatedir ;; + -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ + | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*) + localstatedir=$ac_optarg ;; + + -mandir | --mandir | --mandi | --mand | --man | --ma | --m) + ac_prev=mandir ;; + -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) + mandir=$ac_optarg ;; + + -nfp | --nfp | --nf) + # Obsolete; use --without-fp. + with_fp=no ;; + + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c | -n) + no_create=yes ;; + + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) + no_recursion=yes ;; + + -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ + | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ + | --oldin | --oldi | --old | --ol | --o) + ac_prev=oldincludedir ;; + -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ + | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ + | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) + oldincludedir=$ac_optarg ;; + + -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) + ac_prev=prefix ;; + -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) + prefix=$ac_optarg ;; + + -program-prefix | --program-prefix | --program-prefi | --program-pref \ + | --program-pre | --program-pr | --program-p) + ac_prev=program_prefix ;; + -program-prefix=* | --program-prefix=* | --program-prefi=* \ + | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) + program_prefix=$ac_optarg ;; + + -program-suffix | --program-suffix | --program-suffi | --program-suff \ + | --program-suf | --program-su | --program-s) + ac_prev=program_suffix ;; + -program-suffix=* | --program-suffix=* | --program-suffi=* \ + | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) + program_suffix=$ac_optarg ;; + + -program-transform-name | --program-transform-name \ + | --program-transform-nam | --program-transform-na \ + | --program-transform-n | --program-transform- \ + | --program-transform | --program-transfor \ + | --program-transfo | --program-transf \ + | --program-trans | --program-tran \ + | --progr-tra | --program-tr | --program-t) + ac_prev=program_transform_name ;; + -program-transform-name=* | --program-transform-name=* \ + | --program-transform-nam=* | --program-transform-na=* \ + | --program-transform-n=* | --program-transform-=* \ + | --program-transform=* | --program-transfor=* \ + | --program-transfo=* | --program-transf=* \ + | --program-trans=* | --program-tran=* \ + | --progr-tra=* | --program-tr=* | --program-t=*) + program_transform_name=$ac_optarg ;; + + -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd) + ac_prev=pdfdir ;; + -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*) + pdfdir=$ac_optarg ;; + + -psdir | --psdir | --psdi | --psd | --ps) + ac_prev=psdir ;; + -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*) + psdir=$ac_optarg ;; + + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + silent=yes ;; + + -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) + ac_prev=sbindir ;; + -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ + | --sbi=* | --sb=*) + sbindir=$ac_optarg ;; + + -sharedstatedir | --sharedstatedir | --sharedstatedi \ + | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ + | --sharedst | --shareds | --shared | --share | --shar \ + | --sha | --sh) + ac_prev=sharedstatedir ;; + -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ + | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ + | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ + | --sha=* | --sh=*) + sharedstatedir=$ac_optarg ;; + + -site | --site | --sit) + ac_prev=site ;; + -site=* | --site=* | --sit=*) + site=$ac_optarg ;; + + -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) + ac_prev=srcdir ;; + -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) + srcdir=$ac_optarg ;; + + -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ + | --syscon | --sysco | --sysc | --sys | --sy) + ac_prev=sysconfdir ;; + -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ + | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) + sysconfdir=$ac_optarg ;; + + -target | --target | --targe | --targ | --tar | --ta | --t) + ac_prev=target_alias ;; + -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) + target_alias=$ac_optarg ;; + + -v | -verbose | --verbose | --verbos | --verbo | --verb) + verbose=yes ;; + + -version | --version | --versio | --versi | --vers | -V) + ac_init_version=: ;; + + -with-* | --with-*) + ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid package name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"with_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval with_$ac_useropt=\$ac_optarg ;; + + -without-* | --without-*) + ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && + as_fn_error $? "invalid package name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in + *" +"with_$ac_useropt" +"*) ;; + *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig" + ac_unrecognized_sep=', ';; + esac + eval with_$ac_useropt=no ;; + + --x) + # Obsolete; use --with-x. + with_x=yes ;; + + -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ + | --x-incl | --x-inc | --x-in | --x-i) + ac_prev=x_includes ;; + -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ + | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) + x_includes=$ac_optarg ;; + + -x-libraries | --x-libraries | --x-librarie | --x-librari \ + | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) + ac_prev=x_libraries ;; + -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ + | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) + x_libraries=$ac_optarg ;; + + -*) as_fn_error $? "unrecognized option: \`$ac_option' +Try \`$0 --help' for more information" + ;; + + *=*) + ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` + # Reject names that are not valid shell variable names. + case $ac_envvar in #( + '' | [0-9]* | *[!_$as_cr_alnum]* ) + as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; + esac + eval $ac_envvar=\$ac_optarg + export $ac_envvar ;; + + *) + # FIXME: should be removed in autoconf 3.0. + $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 + expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && + $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 + : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" + ;; + + esac +done + +if test -n "$ac_prev"; then + ac_option=--`echo $ac_prev | sed 's/_/-/g'` + as_fn_error $? "missing argument to $ac_option" +fi + +if test -n "$ac_unrecognized_opts"; then + case $enable_option_checking in + no) ;; + fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; + *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; + esac +fi + +# Check all directory arguments for consistency. +for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \ + datadir sysconfdir sharedstatedir localstatedir includedir \ + oldincludedir docdir infodir htmldir dvidir pdfdir psdir \ + libdir localedir mandir +do + eval ac_val=\$$ac_var + # Remove trailing slashes. + case $ac_val in + */ ) + ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'` + eval $ac_var=\$ac_val;; + esac + # Be sure to have absolute directory names. + case $ac_val in + [\\/$]* | ?:[\\/]* ) continue;; + NONE | '' ) case $ac_var in *prefix ) continue;; esac;; + esac + as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" +done + +# There might be people who depend on the old broken behavior: `$host' +# used to hold the argument of --host etc. +# FIXME: To remove some day. +build=$build_alias +host=$host_alias +target=$target_alias + +# FIXME: To remove some day. +if test "x$host_alias" != x; then + if test "x$build_alias" = x; then + cross_compiling=maybe + elif test "x$build_alias" != "x$host_alias"; then + cross_compiling=yes + fi +fi + +ac_tool_prefix= +test -n "$host_alias" && ac_tool_prefix=$host_alias- + +test "$silent" = yes && exec 6>/dev/null + + +ac_pwd=`pwd` && test -n "$ac_pwd" && +ac_ls_di=`ls -di .` && +ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || + as_fn_error $? "working directory cannot be determined" +test "X$ac_ls_di" = "X$ac_pwd_ls_di" || + as_fn_error $? "pwd does not report name of working directory" + + +# Find the source files, if location was not specified. +if test -z "$srcdir"; then + ac_srcdir_defaulted=yes + # Try the directory containing this script, then the parent directory. + ac_confdir=`$as_dirname -- "$as_myself" || +$as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_myself" : 'X\(//\)[^/]' \| \ + X"$as_myself" : 'X\(//\)$' \| \ + X"$as_myself" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$as_myself" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + srcdir=$ac_confdir + if test ! -r "$srcdir/$ac_unique_file"; then + srcdir=.. + fi +else + ac_srcdir_defaulted=no +fi +if test ! -r "$srcdir/$ac_unique_file"; then + test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." + as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" +fi +ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" +ac_abs_confdir=`( + cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" + pwd)` +# When building in place, set srcdir=. +if test "$ac_abs_confdir" = "$ac_pwd"; then + srcdir=. +fi +# Remove unnecessary trailing slashes from srcdir. +# Double slashes in file names in object file debugging info +# mess up M-x gdb in Emacs. +case $srcdir in +*/) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;; +esac +for ac_var in $ac_precious_vars; do + eval ac_env_${ac_var}_set=\${${ac_var}+set} + eval ac_env_${ac_var}_value=\$${ac_var} + eval ac_cv_env_${ac_var}_set=\${${ac_var}+set} + eval ac_cv_env_${ac_var}_value=\$${ac_var} +done + +# +# Report the --help message. +# +if test "$ac_init_help" = "long"; then + # Omit some internal or obsolete options to make the list less imposing. + # This message is too long to be a string in the A/UX 3.1 sh. + cat <<_ACEOF +\`configure' configures this package to adapt to many kinds of systems. + +Usage: $0 [OPTION]... [VAR=VALUE]... + +To assign environment variables (e.g., CC, CFLAGS...), specify them as +VAR=VALUE. See below for descriptions of some of the useful variables. + +Defaults for the options are specified in brackets. + +Configuration: + -h, --help display this help and exit + --help=short display options specific to this package + --help=recursive display the short help of all the included packages + -V, --version display version information and exit + -q, --quiet, --silent do not print \`checking ...' messages + --cache-file=FILE cache test results in FILE [disabled] + -C, --config-cache alias for \`--cache-file=config.cache' + -n, --no-create do not create output files + --srcdir=DIR find the sources in DIR [configure dir or \`..'] + +Installation directories: + --prefix=PREFIX install architecture-independent files in PREFIX + [$ac_default_prefix] + --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX + [PREFIX] + +By default, \`make install' will install all the files in +\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify +an installation prefix other than \`$ac_default_prefix' using \`--prefix', +for instance \`--prefix=\$HOME'. + +For better control, use the options below. + +Fine tuning of the installation directories: + --bindir=DIR user executables [EPREFIX/bin] + --sbindir=DIR system admin executables [EPREFIX/sbin] + --libexecdir=DIR program executables [EPREFIX/libexec] + --sysconfdir=DIR read-only single-machine data [PREFIX/etc] + --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] + --localstatedir=DIR modifiable single-machine data [PREFIX/var] + --libdir=DIR object code libraries [EPREFIX/lib] + --includedir=DIR C header files [PREFIX/include] + --oldincludedir=DIR C header files for non-gcc [/usr/include] + --datarootdir=DIR read-only arch.-independent data root [PREFIX/share] + --datadir=DIR read-only architecture-independent data [DATAROOTDIR] + --infodir=DIR info documentation [DATAROOTDIR/info] + --localedir=DIR locale-dependent data [DATAROOTDIR/locale] + --mandir=DIR man documentation [DATAROOTDIR/man] + --docdir=DIR documentation root [DATAROOTDIR/doc/PACKAGE] + --htmldir=DIR html documentation [DOCDIR] + --dvidir=DIR dvi documentation [DOCDIR] + --pdfdir=DIR pdf documentation [DOCDIR] + --psdir=DIR ps documentation [DOCDIR] +_ACEOF + + cat <<\_ACEOF +_ACEOF +fi + +if test -n "$ac_init_help"; then + + cat <<\_ACEOF + +Optional Features: + --disable-option-checking ignore unrecognized --enable/--with options + --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) + --enable-FEATURE[=ARG] include FEATURE [ARG=yes] + --enable-threads build with threads (default: on) + --enable-shared build and link with shared libraries (default: on) + --enable-64bit enable 64bit support (where applicable) + --enable-wince enable Win/CE support (where applicable) + --enable-symbols build with debugging symbols (default: off) + --enable-embedded-manifest + embed manifest if possible (default: yes) + +Optional Packages: + --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] + --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) + --with-encoding encoding for configuration values + --with-celib=DIR use Windows/CE support library from DIR + +Some influential environment variables: + CC C compiler command + CFLAGS C compiler flags + LDFLAGS linker flags, e.g. -L<lib dir> if you have libraries in a + nonstandard directory <lib dir> + LIBS libraries to pass to the linker, e.g. -l<library> + CPPFLAGS (Objective) C/C++ preprocessor flags, e.g. -I<include dir> if + you have headers in a nonstandard directory <include dir> + CPP C preprocessor + +Use these variables to override the choices made by `configure' or to help +it to find libraries and programs with nonstandard names/locations. + +Report bugs to the package provider. +_ACEOF +ac_status=$? +fi + +if test "$ac_init_help" = "recursive"; then + # If there are subdirs, report their specific --help. + for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue + test -d "$ac_dir" || + { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } || + continue + ac_builddir=. + +case "$ac_dir" in +.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; +*) + ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` + # A ".." for each directory in $ac_dir_suffix. + ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` + case $ac_top_builddir_sub in + "") ac_top_builddir_sub=. ac_top_build_prefix= ;; + *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; + esac ;; +esac +ac_abs_top_builddir=$ac_pwd +ac_abs_builddir=$ac_pwd$ac_dir_suffix +# for backward compatibility: +ac_top_builddir=$ac_top_build_prefix + +case $srcdir in + .) # We are building in place. + ac_srcdir=. + ac_top_srcdir=$ac_top_builddir_sub + ac_abs_top_srcdir=$ac_pwd ;; + [\\/]* | ?:[\\/]* ) # Absolute name. + ac_srcdir=$srcdir$ac_dir_suffix; + ac_top_srcdir=$srcdir + ac_abs_top_srcdir=$srcdir ;; + *) # Relative name. + ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_build_prefix$srcdir + ac_abs_top_srcdir=$ac_pwd/$srcdir ;; +esac +ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix + + cd "$ac_dir" || { ac_status=$?; continue; } + # Check for guested configure. + if test -f "$ac_srcdir/configure.gnu"; then + echo && + $SHELL "$ac_srcdir/configure.gnu" --help=recursive + elif test -f "$ac_srcdir/configure"; then + echo && + $SHELL "$ac_srcdir/configure" --help=recursive + else + $as_echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 + fi || ac_status=$? + cd "$ac_pwd" || { ac_status=$?; break; } + done +fi + +test -n "$ac_init_help" && exit $ac_status +if $ac_init_version; then + cat <<\_ACEOF +configure +generated by GNU Autoconf 2.69 + +Copyright (C) 2012 Free Software Foundation, Inc. +This configure script is free software; the Free Software Foundation +gives unlimited permission to copy, distribute and modify it. +_ACEOF + exit +fi + +## ------------------------ ## +## Autoconf initialization. ## +## ------------------------ ## + +# ac_fn_c_try_compile LINENO +# -------------------------- +# Try to compile conftest.$ac_ext, and return whether this succeeded. +ac_fn_c_try_compile () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + rm -f conftest.$ac_objext + if { { ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_compile") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + grep -v '^ *+' conftest.err >conftest.er1 + cat conftest.er1 >&5 + mv -f conftest.er1 conftest.err + fi + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest.$ac_objext; then : + ac_retval=0 +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=1 +fi + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_c_try_compile + +# ac_fn_c_try_cpp LINENO +# ---------------------- +# Try to preprocess conftest.$ac_ext, and return whether this succeeded. +ac_fn_c_try_cpp () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + if { { ac_try="$ac_cpp conftest.$ac_ext" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_cpp conftest.$ac_ext") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + grep -v '^ *+' conftest.err >conftest.er1 + cat conftest.er1 >&5 + mv -f conftest.er1 conftest.err + fi + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } > conftest.i && { + test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || + test ! -s conftest.err + }; then : + ac_retval=0 +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=1 +fi + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_c_try_cpp + +# ac_fn_c_try_run LINENO +# ---------------------- +# Try to link conftest.$ac_ext, and return whether this succeeded. Assumes +# that executables *can* be run. +ac_fn_c_try_run () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + if { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } && { ac_try='./conftest$ac_exeext' + { { case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_try") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; }; then : + ac_retval=0 +else + $as_echo "$as_me: program exited with status $ac_status" >&5 + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=$ac_status +fi + rm -rf conftest.dSYM conftest_ipa8_conftest.oo + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_c_try_run + +# ac_fn_c_check_decl LINENO SYMBOL VAR INCLUDES +# --------------------------------------------- +# Tests whether SYMBOL is declared in INCLUDES, setting cache variable VAR +# accordingly. +ac_fn_c_check_decl () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + as_decl_name=`echo $2|sed 's/ *(.*//'` + as_decl_use=`echo $2|sed -e 's/(/((/' -e 's/)/) 0&/' -e 's/,/) 0& (/g'` + { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $as_decl_name is declared" >&5 +$as_echo_n "checking whether $as_decl_name is declared... " >&6; } +if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +int +main () +{ +#ifndef $as_decl_name +#ifdef __cplusplus + (void) $as_decl_use; +#else + (void) $as_decl_name; +#endif +#endif + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + eval "$3=yes" +else + eval "$3=no" +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + +} # ac_fn_c_check_decl + +# ac_fn_c_check_header_compile LINENO HEADER VAR INCLUDES +# ------------------------------------------------------- +# Tests whether HEADER exists and can be compiled using the include files in +# INCLUDES, setting the cache variable VAR accordingly. +ac_fn_c_check_header_compile () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 +$as_echo_n "checking for $2... " >&6; } +if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +#include <$2> +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + eval "$3=yes" +else + eval "$3=no" +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + +} # ac_fn_c_check_header_compile + +# ac_fn_c_check_type LINENO TYPE VAR INCLUDES +# ------------------------------------------- +# Tests whether TYPE exists after having included INCLUDES, setting cache +# variable VAR accordingly. +ac_fn_c_check_type () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 +$as_echo_n "checking for $2... " >&6; } +if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 +else + eval "$3=no" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +int +main () +{ +if (sizeof ($2)) + return 0; + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$4 +int +main () +{ +if (sizeof (($2))) + return 0; + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + +else + eval "$3=yes" +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 +$as_echo "$ac_res" >&6; } + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + +} # ac_fn_c_check_type +cat >config.log <<_ACEOF +This file contains any messages produced by compilers while +running configure, to aid debugging if configure makes a mistake. + +It was created by $as_me, which was +generated by GNU Autoconf 2.69. Invocation command line was + + $ $0 $@ + +_ACEOF +exec 5>>config.log +{ +cat <<_ASUNAME +## --------- ## +## Platform. ## +## --------- ## + +hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` +uname -m = `(uname -m) 2>/dev/null || echo unknown` +uname -r = `(uname -r) 2>/dev/null || echo unknown` +uname -s = `(uname -s) 2>/dev/null || echo unknown` +uname -v = `(uname -v) 2>/dev/null || echo unknown` + +/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` +/bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` + +/bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` +/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` +/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` +/usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown` +/bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` +/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` +/bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` + +_ASUNAME + +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + $as_echo "PATH: $as_dir" + done +IFS=$as_save_IFS + +} >&5 + +cat >&5 <<_ACEOF + + +## ----------- ## +## Core tests. ## +## ----------- ## + +_ACEOF + + +# Keep a trace of the command line. +# Strip out --no-create and --no-recursion so they do not pile up. +# Strip out --silent because we don't want to record it for future runs. +# Also quote any args containing shell meta-characters. +# Make two passes to allow for proper duplicate-argument suppression. +ac_configure_args= +ac_configure_args0= +ac_configure_args1= +ac_must_keep_next=false +for ac_pass in 1 2 +do + for ac_arg + do + case $ac_arg in + -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + continue ;; + *\'*) + ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; + esac + case $ac_pass in + 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;; + 2) + as_fn_append ac_configure_args1 " '$ac_arg'" + if test $ac_must_keep_next = true; then + ac_must_keep_next=false # Got value, back to normal. + else + case $ac_arg in + *=* | --config-cache | -C | -disable-* | --disable-* \ + | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ + | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ + | -with-* | --with-* | -without-* | --without-* | --x) + case "$ac_configure_args0 " in + "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; + esac + ;; + -* ) ac_must_keep_next=true ;; + esac + fi + as_fn_append ac_configure_args " '$ac_arg'" + ;; + esac + done +done +{ ac_configure_args0=; unset ac_configure_args0;} +{ ac_configure_args1=; unset ac_configure_args1;} + +# When interrupted or exit'd, cleanup temporary files, and complete +# config.log. We remove comments because anyway the quotes in there +# would cause problems or look ugly. +# WARNING: Use '\'' to represent an apostrophe within the trap. +# WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug. +trap 'exit_status=$? + # Save into config.log some information that might help in debugging. + { + echo + + $as_echo "## ---------------- ## +## Cache variables. ## +## ---------------- ##" + echo + # The following way of writing the cache mishandles newlines in values, +( + for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do + eval ac_val=\$$ac_var + case $ac_val in #( + *${as_nl}*) + case $ac_var in #( + *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 +$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; + esac + case $ac_var in #( + _ | IFS | as_nl) ;; #( + BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( + *) { eval $ac_var=; unset $ac_var;} ;; + esac ;; + esac + done + (set) 2>&1 | + case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #( + *${as_nl}ac_space=\ *) + sed -n \ + "s/'\''/'\''\\\\'\'''\''/g; + s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p" + ;; #( + *) + sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" + ;; + esac | + sort +) + echo + + $as_echo "## ----------------- ## +## Output variables. ## +## ----------------- ##" + echo + for ac_var in $ac_subst_vars + do + eval ac_val=\$$ac_var + case $ac_val in + *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; + esac + $as_echo "$ac_var='\''$ac_val'\''" + done | sort + echo + + if test -n "$ac_subst_files"; then + $as_echo "## ------------------- ## +## File substitutions. ## +## ------------------- ##" + echo + for ac_var in $ac_subst_files + do + eval ac_val=\$$ac_var + case $ac_val in + *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;; + esac + $as_echo "$ac_var='\''$ac_val'\''" + done | sort + echo + fi + + if test -s confdefs.h; then + $as_echo "## ----------- ## +## confdefs.h. ## +## ----------- ##" + echo + cat confdefs.h + echo + fi + test "$ac_signal" != 0 && + $as_echo "$as_me: caught signal $ac_signal" + $as_echo "$as_me: exit $exit_status" + } >&5 + rm -f core *.core core.conftest.* && + rm -f -r conftest* confdefs* conf$$* $ac_clean_files && + exit $exit_status +' 0 +for ac_signal in 1 2 13 15; do + trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal +done +ac_signal=0 + +# confdefs.h avoids OS command line length limits that DEFS can exceed. +rm -f -r conftest* confdefs.h + +$as_echo "/* confdefs.h */" > confdefs.h + +# Predefined preprocessor variables. + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_NAME "$PACKAGE_NAME" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_TARNAME "$PACKAGE_TARNAME" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_VERSION "$PACKAGE_VERSION" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_STRING "$PACKAGE_STRING" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" +_ACEOF + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_URL "$PACKAGE_URL" +_ACEOF + + +# Let the site file select an alternate cache file if it wants to. +# Prefer an explicitly selected file to automatically selected ones. +ac_site_file1=NONE +ac_site_file2=NONE +if test -n "$CONFIG_SITE"; then + # We do not want a PATH search for config.site. + case $CONFIG_SITE in #(( + -*) ac_site_file1=./$CONFIG_SITE;; + */*) ac_site_file1=$CONFIG_SITE;; + *) ac_site_file1=./$CONFIG_SITE;; + esac +elif test "x$prefix" != xNONE; then + ac_site_file1=$prefix/share/config.site + ac_site_file2=$prefix/etc/config.site +else + ac_site_file1=$ac_default_prefix/share/config.site + ac_site_file2=$ac_default_prefix/etc/config.site +fi +for ac_site_file in "$ac_site_file1" "$ac_site_file2" +do + test "x$ac_site_file" = xNONE && continue + if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 +$as_echo "$as_me: loading site script $ac_site_file" >&6;} + sed 's/^/| /' "$ac_site_file" >&5 + . "$ac_site_file" \ + || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "failed to load site script $ac_site_file +See \`config.log' for more details" "$LINENO" 5; } + fi +done + +if test -r "$cache_file"; then + # Some versions of bash will fail to source /dev/null (special files + # actually), so we avoid doing that. DJGPP emulates it as a regular file. + if test /dev/null != "$cache_file" && test -f "$cache_file"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5 +$as_echo "$as_me: loading cache $cache_file" >&6;} + case $cache_file in + [\\/]* | ?:[\\/]* ) . "$cache_file";; + *) . "./$cache_file";; + esac + fi +else + { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5 +$as_echo "$as_me: creating cache $cache_file" >&6;} + >$cache_file +fi + +# Check that the precious variables saved in the cache have kept the same +# value. +ac_cache_corrupted=false +for ac_var in $ac_precious_vars; do + eval ac_old_set=\$ac_cv_env_${ac_var}_set + eval ac_new_set=\$ac_env_${ac_var}_set + eval ac_old_val=\$ac_cv_env_${ac_var}_value + eval ac_new_val=\$ac_env_${ac_var}_value + case $ac_old_set,$ac_new_set in + set,) + { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 +$as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} + ac_cache_corrupted=: ;; + ,set) + { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5 +$as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} + ac_cache_corrupted=: ;; + ,);; + *) + if test "x$ac_old_val" != "x$ac_new_val"; then + # differences in whitespace do not lead to failure. + ac_old_val_w=`echo x $ac_old_val` + ac_new_val_w=`echo x $ac_new_val` + if test "$ac_old_val_w" != "$ac_new_val_w"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5 +$as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} + ac_cache_corrupted=: + else + { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5 +$as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;} + eval $ac_var=\$ac_old_val + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5 +$as_echo "$as_me: former value: \`$ac_old_val'" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5 +$as_echo "$as_me: current value: \`$ac_new_val'" >&2;} + fi;; + esac + # Pass precious variables to config.status. + if test "$ac_new_set" = set; then + case $ac_new_val in + *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; + *) ac_arg=$ac_var=$ac_new_val ;; + esac + case " $ac_configure_args " in + *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. + *) as_fn_append ac_configure_args " '$ac_arg'" ;; + esac + fi +done +if $ac_cache_corrupted; then + { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 +$as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} + as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 +fi +## -------------------- ## +## Main body of script. ## +## -------------------- ## + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + + + +# The following define is needed when building with Cygwin since newer +# versions of autoconf incorrectly set SHELL to /bin/bash instead of +# /bin/sh. The bash shell seems to suffer from some strange failures. +SHELL=/bin/sh + +TCL_VERSION=8.7 +TCL_MAJOR_VERSION=8 +TCL_MINOR_VERSION=7 +TCL_PATCH_LEVEL="a2" +VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION + +TCL_DDE_VERSION=1.4 +TCL_DDE_MAJOR_VERSION=1 +TCL_DDE_MINOR_VERSION=4 +DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION + +TCL_REG_VERSION=1.3 +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 +#------------------------------------------------------------------------ + +if test "${prefix}" = "NONE"; then + prefix=/usr/local +fi +if test "${exec_prefix}" = "NONE"; then + exec_prefix=$prefix +fi +# libdir must be a fully qualified path (not ${exec_prefix}/lib) +eval libdir="$libdir" + +#------------------------------------------------------------------------ +# Standard compiler checks +#------------------------------------------------------------------------ + +# If the user did not set CFLAGS, set it now to keep +# the AC_PROG_CC macro from adding "-g -O2". +if test "${CFLAGS+set}" != "set" ; then + CFLAGS="" +fi + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu +if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args. +set dummy ${ac_tool_prefix}gcc; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="${ac_tool_prefix}gcc" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 +$as_echo "$CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + +fi +if test -z "$ac_cv_prog_CC"; then + ac_ct_CC=$CC + # Extract the first word of "gcc", so it can be a program name with args. +set dummy gcc; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_ac_ct_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$ac_ct_CC"; then + ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_CC="gcc" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_CC=$ac_cv_prog_ac_ct_CC +if test -n "$ac_ct_CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 +$as_echo "$ac_ct_CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + if test "x$ac_ct_CC" = x; then + CC="" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + CC=$ac_ct_CC + fi +else + CC="$ac_cv_prog_CC" +fi + +if test -z "$CC"; then + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args. +set dummy ${ac_tool_prefix}cc; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="${ac_tool_prefix}cc" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 +$as_echo "$CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + fi +fi +if test -z "$CC"; then + # Extract the first word of "cc", so it can be a program name with args. +set dummy cc; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else + ac_prog_rejected=no +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + if test "$as_dir/$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then + ac_prog_rejected=yes + continue + fi + ac_cv_prog_CC="cc" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +if test $ac_prog_rejected = yes; then + # We found a bogon in the path, so make sure we never use it. + set dummy $ac_cv_prog_CC + shift + if test $# != 0; then + # We chose a different compiler from the bogus one. + # However, it has the same basename, so the bogon will be chosen + # first if we set CC to just the basename; use the full file name. + shift + ac_cv_prog_CC="$as_dir/$ac_word${1+' '}$@" + fi +fi +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 +$as_echo "$CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + +fi +if test -z "$CC"; then + if test -n "$ac_tool_prefix"; then + for ac_prog in cl.exe + do + # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. +set dummy $ac_tool_prefix$ac_prog; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="$ac_tool_prefix$ac_prog" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 +$as_echo "$CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + test -n "$CC" && break + done +fi +if test -z "$CC"; then + ac_ct_CC=$CC + for ac_prog in cl.exe +do + # Extract the first word of "$ac_prog", so it can be a program name with args. +set dummy $ac_prog; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_ac_ct_CC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$ac_ct_CC"; then + ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_CC="$ac_prog" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_CC=$ac_cv_prog_ac_ct_CC +if test -n "$ac_ct_CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5 +$as_echo "$ac_ct_CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + test -n "$ac_ct_CC" && break +done + + if test "x$ac_ct_CC" = x; then + CC="" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + CC=$ac_ct_CC + fi +fi + +fi + + +test -z "$CC" && { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "no acceptable C compiler found in \$PATH +See \`config.log' for more details" "$LINENO" 5; } + +# Provide some information about the compiler. +$as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5 +set X $ac_compile +ac_compiler=$2 +for ac_option in --version -v -V -qversion; do + { { ac_try="$ac_compiler $ac_option >&5" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_compiler $ac_option >&5") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + sed '10a\ +... rest of stderr output deleted ... + 10q' conftest.err >conftest.er1 + cat conftest.er1 >&5 + fi + rm -f conftest.er1 conftest.err + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } +done + +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +ac_clean_files_save=$ac_clean_files +ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out" +# Try to create an executable without -o first, disregard a.out. +# It will help us diagnose broken compilers, and finding out an intuition +# of exeext. +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the C compiler works" >&5 +$as_echo_n "checking whether the C compiler works... " >&6; } +ac_link_default=`$as_echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` + +# The possible output files: +ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*" + +ac_rmfiles= +for ac_file in $ac_files +do + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; + * ) ac_rmfiles="$ac_rmfiles $ac_file";; + esac +done +rm -f $ac_rmfiles + +if { { ac_try="$ac_link_default" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link_default") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; then : + # Autoconf-2.13 could set the ac_cv_exeext variable to `no'. +# So ignore a value of `no', otherwise this would lead to `EXEEXT = no' +# in a Makefile. We should not override ac_cv_exeext if it was cached, +# so that the user can short-circuit this test for compilers unknown to +# Autoconf. +for ac_file in $ac_files '' +do + test -f "$ac_file" || continue + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) + ;; + [ab].out ) + # We found the default executable, but exeext='' is most + # certainly right. + break;; + *.* ) + if test "${ac_cv_exeext+set}" = set && test "$ac_cv_exeext" != no; + then :; else + ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` + fi + # We set ac_cv_exeext here because the later test for it is not + # safe: cross compilers may not add the suffix if given an `-o' + # argument, so we may need to know it at that point already. + # Even if this section looks crufty: it has the advantage of + # actually working. + break;; + * ) + break;; + esac +done +test "$ac_cv_exeext" = no && ac_cv_exeext= + +else + ac_file='' +fi +if test -z "$ac_file"; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +$as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error 77 "C compiler cannot create executables +See \`config.log' for more details" "$LINENO" 5; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler default output file name" >&5 +$as_echo_n "checking for C compiler default output file name... " >&6; } +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5 +$as_echo "$ac_file" >&6; } +ac_exeext=$ac_cv_exeext + +rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out +ac_clean_files=$ac_clean_files_save +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5 +$as_echo_n "checking for suffix of executables... " >&6; } +if { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; then : + # If both `conftest.exe' and `conftest' are `present' (well, observable) +# catch `conftest.exe'. For instance with Cygwin, `ls conftest' will +# work properly (i.e., refer to `conftest.exe'), while it won't with +# `rm'. +for ac_file in conftest.exe conftest conftest.*; do + test -f "$ac_file" || continue + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;; + *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` + break;; + * ) break;; + esac +done +else + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot compute suffix of executables: cannot compile and link +See \`config.log' for more details" "$LINENO" 5; } +fi +rm -f conftest conftest$ac_cv_exeext +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 +$as_echo "$ac_cv_exeext" >&6; } + +rm -f conftest.$ac_ext +EXEEXT=$ac_cv_exeext +ac_exeext=$EXEEXT +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include <stdio.h> +int +main () +{ +FILE *f = fopen ("conftest.out", "w"); + return ferror (f) || fclose (f) != 0; + + ; + return 0; +} +_ACEOF +ac_clean_files="$ac_clean_files conftest.out" +# Check that the compiler produces executables we can run. If not, either +# the compiler is broken, or we cross compile. +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5 +$as_echo_n "checking whether we are cross compiling... " >&6; } +if test "$cross_compiling" != yes; then + { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } + if { ac_try='./conftest$ac_cv_exeext' + { { case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_try") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; }; then + cross_compiling=no + else + if test "$cross_compiling" = maybe; then + cross_compiling=yes + else + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot run C compiled programs. +If you meant to cross compile, use \`--host'. +See \`config.log' for more details" "$LINENO" 5; } + fi + fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5 +$as_echo "$cross_compiling" >&6; } + +rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out +ac_clean_files=$ac_clean_files_save +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5 +$as_echo_n "checking for suffix of object files... " >&6; } +if ${ac_cv_objext+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +rm -f conftest.o conftest.obj +if { { ac_try="$ac_compile" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_compile") 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; then : + for ac_file in conftest.o conftest.obj conftest.*; do + test -f "$ac_file" || continue; + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;; + *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` + break;; + esac +done +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "cannot compute suffix of object files: cannot compile +See \`config.log' for more details" "$LINENO" 5; } +fi +rm -f conftest.$ac_cv_objext conftest.$ac_ext +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5 +$as_echo "$ac_cv_objext" >&6; } +OBJEXT=$ac_cv_objext +ac_objext=$OBJEXT +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU C compiler" >&5 +$as_echo_n "checking whether we are using the GNU C compiler... " >&6; } +if ${ac_cv_c_compiler_gnu+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ +#ifndef __GNUC__ + choke me +#endif + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_compiler_gnu=yes +else + ac_compiler_gnu=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +ac_cv_c_compiler_gnu=$ac_compiler_gnu + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5 +$as_echo "$ac_cv_c_compiler_gnu" >&6; } +if test $ac_compiler_gnu = yes; then + GCC=yes +else + GCC= +fi +ac_test_CFLAGS=${CFLAGS+set} +ac_save_CFLAGS=$CFLAGS +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5 +$as_echo_n "checking whether $CC accepts -g... " >&6; } +if ${ac_cv_prog_cc_g+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_save_c_werror_flag=$ac_c_werror_flag + ac_c_werror_flag=yes + ac_cv_prog_cc_g=no + CFLAGS="-g" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_prog_cc_g=yes +else + CFLAGS="" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + +else + ac_c_werror_flag=$ac_save_c_werror_flag + CFLAGS="-g" + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_prog_cc_g=yes +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + ac_c_werror_flag=$ac_save_c_werror_flag +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5 +$as_echo "$ac_cv_prog_cc_g" >&6; } +if test "$ac_test_CFLAGS" = set; then + CFLAGS=$ac_save_CFLAGS +elif test $ac_cv_prog_cc_g = yes; then + if test "$GCC" = yes; then + CFLAGS="-g -O2" + else + CFLAGS="-g" + fi +else + if test "$GCC" = yes; then + CFLAGS="-O2" + else + CFLAGS= + fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO C89" >&5 +$as_echo_n "checking for $CC option to accept ISO C89... " >&6; } +if ${ac_cv_prog_cc_c89+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_cv_prog_cc_c89=no +ac_save_CC=$CC +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include <stdarg.h> +#include <stdio.h> +struct stat; +/* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */ +struct buf { int x; }; +FILE * (*rcsopen) (struct buf *, struct stat *, int); +static char *e (p, i) + char **p; + int i; +{ + return p[i]; +} +static char *f (char * (*g) (char **, int), char **p, ...) +{ + char *s; + va_list v; + va_start (v,p); + s = g (p, va_arg (v,int)); + va_end (v); + return s; +} + +/* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has + function prototypes and stuff, but not '\xHH' hex character constants. + These don't provoke an error unfortunately, instead are silently treated + as 'x'. The following induces an error, until -std is added to get + proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an + array size at least. It's necessary to write '\x00'==0 to get something + that's true only with -std. */ +int osf4_cc_array ['\x00' == 0 ? 1 : -1]; + +/* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters + inside strings and character constants. */ +#define FOO(x) 'x' +int xlc6_cc_array[FOO(a) == 'x' ? 1 : -1]; + +int test (int i, double x); +struct s1 {int (*f) (int a);}; +struct s2 {int (*f) (double a);}; +int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int); +int argc; +char **argv; +int +main () +{ +return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]; + ; + return 0; +} +_ACEOF +for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std \ + -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" +do + CC="$ac_save_CC $ac_arg" + if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_prog_cc_c89=$ac_arg +fi +rm -f core conftest.err conftest.$ac_objext + test "x$ac_cv_prog_cc_c89" != "xno" && break +done +rm -f conftest.$ac_ext +CC=$ac_save_CC + +fi +# AC_CACHE_VAL +case "x$ac_cv_prog_cc_c89" in + x) + { $as_echo "$as_me:${as_lineno-$LINENO}: result: none needed" >&5 +$as_echo "none needed" >&6; } ;; + xno) + { $as_echo "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5 +$as_echo "unsupported" >&6; } ;; + *) + CC="$CC $ac_cv_prog_cc_c89" + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5 +$as_echo "$ac_cv_prog_cc_c89" >&6; } ;; +esac +if test "x$ac_cv_prog_cc_c89" != xno; then : + +fi + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for inline" >&5 +$as_echo_n "checking for inline... " >&6; } +if ${ac_cv_c_inline+:} false; then : + $as_echo_n "(cached) " >&6 +else + ac_cv_c_inline=no +for ac_kw in inline __inline__ __inline; do + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#ifndef __cplusplus +typedef int foo_t; +static $ac_kw foo_t static_foo () {return 0; } +$ac_kw foo_t foo () {return 0; } +#endif + +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_c_inline=$ac_kw +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + test "$ac_cv_c_inline" != no && break +done + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_inline" >&5 +$as_echo "$ac_cv_c_inline" >&6; } + +case $ac_cv_c_inline in + inline | yes) ;; + *) + case $ac_cv_c_inline in + no) ac_val=;; + *) ac_val=$ac_cv_c_inline;; + esac + cat >>confdefs.h <<_ACEOF +#ifndef __cplusplus +#define inline $ac_val +#endif +_ACEOF + ;; +esac + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking how to run the C preprocessor" >&5 +$as_echo_n "checking how to run the C preprocessor... " >&6; } +# On Suns, sometimes $CPP names a directory. +if test -n "$CPP" && test -d "$CPP"; then + CPP= +fi +if test -z "$CPP"; then + if ${ac_cv_prog_CPP+:} false; then : + $as_echo_n "(cached) " >&6 +else + # Double quotes because CPP needs to be expanded + for CPP in "$CC -E" "$CC -E -traditional-cpp" "/lib/cpp" + do + ac_preproc_ok=false +for ac_c_preproc_warn_flag in '' yes +do + # Use a header file that comes with gcc, so configuring glibc + # with a fresh cross-compiler works. + # Prefer <limits.h> to <assert.h> if __STDC__ is defined, since + # <limits.h> exists even on freestanding compilers. + # On the NeXT, cc -E runs the code through the compiler's parser, + # not just through cpp. "Syntax error" is here to catch this case. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#ifdef __STDC__ +# include <limits.h> +#else +# include <assert.h> +#endif + Syntax error +_ACEOF +if ac_fn_c_try_cpp "$LINENO"; then : + +else + # Broken: fails on valid input. +continue +fi +rm -f conftest.err conftest.i conftest.$ac_ext + + # OK, works on sane cases. Now check whether nonexistent headers + # can be detected and how. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include <ac_nonexistent.h> +_ACEOF +if ac_fn_c_try_cpp "$LINENO"; then : + # Broken: success on invalid input. +continue +else + # Passes both tests. +ac_preproc_ok=: +break +fi +rm -f conftest.err conftest.i conftest.$ac_ext + +done +# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. +rm -f conftest.i conftest.err conftest.$ac_ext +if $ac_preproc_ok; then : + break +fi + + done + ac_cv_prog_CPP=$CPP + +fi + CPP=$ac_cv_prog_CPP +else + ac_cv_prog_CPP=$CPP +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $CPP" >&5 +$as_echo "$CPP" >&6; } +ac_preproc_ok=false +for ac_c_preproc_warn_flag in '' yes +do + # Use a header file that comes with gcc, so configuring glibc + # with a fresh cross-compiler works. + # Prefer <limits.h> to <assert.h> if __STDC__ is defined, since + # <limits.h> exists even on freestanding compilers. + # On the NeXT, cc -E runs the code through the compiler's parser, + # not just through cpp. "Syntax error" is here to catch this case. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#ifdef __STDC__ +# include <limits.h> +#else +# include <assert.h> +#endif + Syntax error +_ACEOF +if ac_fn_c_try_cpp "$LINENO"; then : + +else + # Broken: fails on valid input. +continue +fi +rm -f conftest.err conftest.i conftest.$ac_ext + + # OK, works on sane cases. Now check whether nonexistent headers + # can be detected and how. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include <ac_nonexistent.h> +_ACEOF +if ac_fn_c_try_cpp "$LINENO"; then : + # Broken: success on invalid input. +continue +else + # Passes both tests. +ac_preproc_ok=: +break +fi +rm -f conftest.err conftest.i conftest.$ac_ext + +done +# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. +rm -f conftest.i conftest.err conftest.$ac_ext +if $ac_preproc_ok; then : + +else + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 +$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +as_fn_error $? "C preprocessor \"$CPP\" fails sanity check +See \`config.log' for more details" "$LINENO" 5; } +fi + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for grep that handles long lines and -e" >&5 +$as_echo_n "checking for grep that handles long lines and -e... " >&6; } +if ${ac_cv_path_GREP+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -z "$GREP"; then + ac_path_GREP_found=false + # Loop through the user's path and test for each of PROGNAME-LIST + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_prog in grep ggrep; do + for ac_exec_ext in '' $ac_executable_extensions; do + ac_path_GREP="$as_dir/$ac_prog$ac_exec_ext" + as_fn_executable_p "$ac_path_GREP" || continue +# Check for GNU ac_path_GREP and select it if it is found. + # Check for GNU $ac_path_GREP +case `"$ac_path_GREP" --version 2>&1` in +*GNU*) + ac_cv_path_GREP="$ac_path_GREP" ac_path_GREP_found=:;; +*) + ac_count=0 + $as_echo_n 0123456789 >"conftest.in" + while : + do + cat "conftest.in" "conftest.in" >"conftest.tmp" + mv "conftest.tmp" "conftest.in" + cp "conftest.in" "conftest.nl" + $as_echo 'GREP' >> "conftest.nl" + "$ac_path_GREP" -e 'GREP$' -e '-(cannot match)-' < "conftest.nl" >"conftest.out" 2>/dev/null || break + diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break + as_fn_arith $ac_count + 1 && ac_count=$as_val + if test $ac_count -gt ${ac_path_GREP_max-0}; then + # Best one so far, save it but keep looking for a better one + ac_cv_path_GREP="$ac_path_GREP" + ac_path_GREP_max=$ac_count + fi + # 10*(2^10) chars as input seems more than enough + test $ac_count -gt 10 && break + done + rm -f conftest.in conftest.tmp conftest.nl conftest.out;; +esac + + $ac_path_GREP_found && break 3 + done + done + done +IFS=$as_save_IFS + if test -z "$ac_cv_path_GREP"; then + as_fn_error $? "no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 + fi +else + ac_cv_path_GREP=$GREP +fi + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_GREP" >&5 +$as_echo "$ac_cv_path_GREP" >&6; } + GREP="$ac_cv_path_GREP" + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for egrep" >&5 +$as_echo_n "checking for egrep... " >&6; } +if ${ac_cv_path_EGREP+:} false; then : + $as_echo_n "(cached) " >&6 +else + if echo a | $GREP -E '(a|b)' >/dev/null 2>&1 + then ac_cv_path_EGREP="$GREP -E" + else + if test -z "$EGREP"; then + ac_path_EGREP_found=false + # Loop through the user's path and test for each of PROGNAME-LIST + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH$PATH_SEPARATOR/usr/xpg4/bin +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_prog in egrep; do + for ac_exec_ext in '' $ac_executable_extensions; do + ac_path_EGREP="$as_dir/$ac_prog$ac_exec_ext" + as_fn_executable_p "$ac_path_EGREP" || continue +# Check for GNU ac_path_EGREP and select it if it is found. + # Check for GNU $ac_path_EGREP +case `"$ac_path_EGREP" --version 2>&1` in +*GNU*) + ac_cv_path_EGREP="$ac_path_EGREP" ac_path_EGREP_found=:;; +*) + ac_count=0 + $as_echo_n 0123456789 >"conftest.in" + while : + do + cat "conftest.in" "conftest.in" >"conftest.tmp" + mv "conftest.tmp" "conftest.in" + cp "conftest.in" "conftest.nl" + $as_echo 'EGREP' >> "conftest.nl" + "$ac_path_EGREP" 'EGREP$' < "conftest.nl" >"conftest.out" 2>/dev/null || break + diff "conftest.out" "conftest.nl" >/dev/null 2>&1 || break + as_fn_arith $ac_count + 1 && ac_count=$as_val + if test $ac_count -gt ${ac_path_EGREP_max-0}; then + # Best one so far, save it but keep looking for a better one + ac_cv_path_EGREP="$ac_path_EGREP" + ac_path_EGREP_max=$ac_count + fi + # 10*(2^10) chars as input seems more than enough + test $ac_count -gt 10 && break + done + rm -f conftest.in conftest.tmp conftest.nl conftest.out;; +esac + + $ac_path_EGREP_found && break 3 + done + done + done +IFS=$as_save_IFS + if test -z "$ac_cv_path_EGREP"; then + as_fn_error $? "no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 + fi +else + ac_cv_path_EGREP=$EGREP +fi + + fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_path_EGREP" >&5 +$as_echo "$ac_cv_path_EGREP" >&6; } + EGREP="$ac_cv_path_EGREP" + + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for ANSI C header files" >&5 +$as_echo_n "checking for ANSI C header files... " >&6; } +if ${ac_cv_header_stdc+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include <stdlib.h> +#include <stdarg.h> +#include <string.h> +#include <float.h> + +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_header_stdc=yes +else + ac_cv_header_stdc=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + +if test $ac_cv_header_stdc = yes; then + # SunOS 4.x string.h does not declare mem*, contrary to ANSI. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include <string.h> + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "memchr" >/dev/null 2>&1; then : + +else + ac_cv_header_stdc=no +fi +rm -f conftest* + +fi + +if test $ac_cv_header_stdc = yes; then + # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include <stdlib.h> + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "free" >/dev/null 2>&1; then : + +else + ac_cv_header_stdc=no +fi +rm -f conftest* + +fi + +if test $ac_cv_header_stdc = yes; then + # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. + if test "$cross_compiling" = yes; then : + : +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +#include <ctype.h> +#include <stdlib.h> +#if ((' ' & 0x0FF) == 0x020) +# define ISLOWER(c) ('a' <= (c) && (c) <= 'z') +# define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) +#else +# define ISLOWER(c) \ + (('a' <= (c) && (c) <= 'i') \ + || ('j' <= (c) && (c) <= 'r') \ + || ('s' <= (c) && (c) <= 'z')) +# define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c)) +#endif + +#define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) +int +main () +{ + int i; + for (i = 0; i < 256; i++) + if (XOR (islower (i), ISLOWER (i)) + || toupper (i) != TOUPPER (i)) + return 2; + return 0; +} +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + +else + ac_cv_header_stdc=no +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + +fi +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_header_stdc" >&5 +$as_echo "$ac_cv_header_stdc" >&6; } +if test $ac_cv_header_stdc = yes; then + +$as_echo "#define STDC_HEADERS 1" >>confdefs.h + +fi + + +if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}ar", so it can be a program name with args. +set dummy ${ac_tool_prefix}ar; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_AR+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$AR"; then + ac_cv_prog_AR="$AR" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_AR="${ac_tool_prefix}ar" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +AR=$ac_cv_prog_AR +if test -n "$AR"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $AR" >&5 +$as_echo "$AR" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + +fi +if test -z "$ac_cv_prog_AR"; then + ac_ct_AR=$AR + # Extract the first word of "ar", so it can be a program name with args. +set dummy ar; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_ac_ct_AR+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$ac_ct_AR"; then + ac_cv_prog_ac_ct_AR="$ac_ct_AR" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_AR="ar" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_AR=$ac_cv_prog_ac_ct_AR +if test -n "$ac_ct_AR"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_AR" >&5 +$as_echo "$ac_ct_AR" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + if test "x$ac_ct_AR" = x; then + AR="" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + AR=$ac_ct_AR + fi +else + AR="$ac_cv_prog_AR" +fi + +if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}ranlib", so it can be a program name with args. +set dummy ${ac_tool_prefix}ranlib; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_RANLIB+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$RANLIB"; then + ac_cv_prog_RANLIB="$RANLIB" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_RANLIB="${ac_tool_prefix}ranlib" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +RANLIB=$ac_cv_prog_RANLIB +if test -n "$RANLIB"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $RANLIB" >&5 +$as_echo "$RANLIB" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + +fi +if test -z "$ac_cv_prog_RANLIB"; then + ac_ct_RANLIB=$RANLIB + # Extract the first word of "ranlib", so it can be a program name with args. +set dummy ranlib; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_ac_ct_RANLIB+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$ac_ct_RANLIB"; then + ac_cv_prog_ac_ct_RANLIB="$ac_ct_RANLIB" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_RANLIB="ranlib" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_RANLIB=$ac_cv_prog_ac_ct_RANLIB +if test -n "$ac_ct_RANLIB"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_RANLIB" >&5 +$as_echo "$ac_ct_RANLIB" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + if test "x$ac_ct_RANLIB" = x; then + RANLIB="" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + RANLIB=$ac_ct_RANLIB + fi +else + RANLIB="$ac_cv_prog_RANLIB" +fi + +if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}windres", so it can be a program name with args. +set dummy ${ac_tool_prefix}windres; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_RC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$RC"; then + ac_cv_prog_RC="$RC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_RC="${ac_tool_prefix}windres" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +RC=$ac_cv_prog_RC +if test -n "$RC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $RC" >&5 +$as_echo "$RC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + +fi +if test -z "$ac_cv_prog_RC"; then + ac_ct_RC=$RC + # Extract the first word of "windres", so it can be a program name with args. +set dummy windres; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_ac_ct_RC+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$ac_ct_RC"; then + ac_cv_prog_ac_ct_RC="$ac_ct_RC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_RC="windres" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + +fi +fi +ac_ct_RC=$ac_cv_prog_ac_ct_RC +if test -n "$ac_ct_RC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_RC" >&5 +$as_echo "$ac_ct_RC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + if test "x$ac_ct_RC" = x; then + RC="" + else + case $cross_compiling:$ac_tool_warned in +yes:) +{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5 +$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;} +ac_tool_warned=yes ;; +esac + RC=$ac_ct_RC + fi +else + RC="$ac_cv_prog_RC" +fi + + +#-------------------------------------------------------------------- +# Checks to see if the make program sets the $MAKE variable. +#-------------------------------------------------------------------- + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether ${MAKE-make} sets \$(MAKE)" >&5 +$as_echo_n "checking whether ${MAKE-make} sets \$(MAKE)... " >&6; } +set x ${MAKE-make} +ac_make=`$as_echo "$2" | sed 's/+/p/g; s/[^a-zA-Z0-9_]/_/g'` +if eval \${ac_cv_prog_make_${ac_make}_set+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat >conftest.make <<\_ACEOF +SHELL = /bin/sh +all: + @echo '@@@%%%=$(MAKE)=@@@%%%' +_ACEOF +# GNU make sometimes prints "make[1]: Entering ...", which would confuse us. +case `${MAKE-make} -f conftest.make 2>/dev/null` in + *@@@%%%=?*=@@@%%%*) + eval ac_cv_prog_make_${ac_make}_set=yes;; + *) + eval ac_cv_prog_make_${ac_make}_set=no;; +esac +rm -f conftest.make +fi +if eval test \$ac_cv_prog_make_${ac_make}_set = yes; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } + SET_MAKE= +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } + SET_MAKE="MAKE=${MAKE-make}" +fi + + +#-------------------------------------------------------------------- +# Determines the correct binary file extension (.o, .obj, .exe etc.) +#-------------------------------------------------------------------- + + + + +#-------------------------------------------------------------------- +# Check whether --enable-threads or --disable-threads was given. +#-------------------------------------------------------------------- + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for building with threads" >&5 +$as_echo_n "checking for building with threads... " >&6; } + # Check whether --enable-threads was given. +if test "${enable_threads+set}" = set; then : + enableval=$enable_threads; tcl_ok=$enableval +else + tcl_ok=yes +fi + + + if test "$tcl_ok" = "yes"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes (default)" >&5 +$as_echo "yes (default)" >&6; } + TCL_THREADS=1 + $as_echo "#define TCL_THREADS 1" >>confdefs.h + + # USE_THREAD_ALLOC tells us to try the special thread-based + # allocator that significantly reduces lock contention + $as_echo "#define USE_THREAD_ALLOC 1" >>confdefs.h + + else + TCL_THREADS=0 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } + fi + + + +#------------------------------------------------------------------------ +# Embedded configuration information, encoding to use for the values, TIP #59 +#------------------------------------------------------------------------ + + + +# Check whether --with-encoding was given. +if test "${with_encoding+set}" = set; then : + withval=$with_encoding; with_tcencoding=${withval} +fi + + + if test x"${with_tcencoding}" != x ; then + cat >>confdefs.h <<_ACEOF +#define TCL_CFGVAL_ENCODING "${with_tcencoding}" +_ACEOF + + else + # Default encoding on windows is not "iso8859-1" + $as_echo "#define TCL_CFGVAL_ENCODING \"cp1252\"" >>confdefs.h + + fi + + +#-------------------------------------------------------------------- +# The statements below define a collection of symbols related to +# building libtcl as a shared library instead of a static library. +#-------------------------------------------------------------------- + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking how to build libraries" >&5 +$as_echo_n "checking how to build libraries... " >&6; } + # Check whether --enable-shared was given. +if test "${enable_shared+set}" = set; then : + enableval=$enable_shared; tcl_ok=$enableval +else + tcl_ok=yes +fi + + + if test "${enable_shared+set}" = set; then + enableval="$enable_shared" + tcl_ok=$enableval + else + tcl_ok=yes + fi + + if test "$tcl_ok" = "yes" ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: shared" >&5 +$as_echo "shared" >&6; } + SHARED_BUILD=1 + else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: static" >&5 +$as_echo "static" >&6; } + SHARED_BUILD=0 + +$as_echo "#define STATIC_BUILD 1" >>confdefs.h + + fi + + +#-------------------------------------------------------------------- +# The statements below define a collection of compile flags. This +# macro depends on the value of SHARED_BUILD, and should be called +# after SC_ENABLE_SHARED checks the configure switches. +#-------------------------------------------------------------------- + +# On IRIX 5.3, sys/types and inttypes.h are conflicting. +for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \ + inttypes.h stdint.h unistd.h +do : + as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` +ac_fn_c_check_header_compile "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default +" +if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : + cat >>confdefs.h <<_ACEOF +#define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 +_ACEOF + +fi + +done + + + + + # Step 0: Enable 64 bit support? + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking if 64bit support is requested" >&5 +$as_echo_n "checking if 64bit support is requested... " >&6; } + # Check whether --enable-64bit was given. +if test "${enable_64bit+set}" = set; then : + enableval=$enable_64bit; do64bit=$enableval +else + do64bit=no +fi + + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $do64bit" >&5 +$as_echo "$do64bit" >&6; } + + # Cross-compiling options for Windows/CE builds + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking if Windows/CE build is requested" >&5 +$as_echo_n "checking if Windows/CE build is requested... " >&6; } + # Check whether --enable-wince was given. +if test "${enable_wince+set}" = set; then : + enableval=$enable_wince; doWince=$enableval +else + doWince=no +fi + + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $doWince" >&5 +$as_echo "$doWince" >&6; } + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for Windows/CE celib directory" >&5 +$as_echo_n "checking for Windows/CE celib directory... " >&6; } + +# Check whether --with-celib was given. +if test "${with_celib+set}" = set; then : + withval=$with_celib; CELIB_DIR=$withval +else + CELIB_DIR=NO_CELIB +fi + + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CELIB_DIR" >&5 +$as_echo "$CELIB_DIR" >&6; } + + # Set some defaults (may get changed below) + EXTRA_CFLAGS="" + +$as_echo "#define MODULE_SCOPE extern" >>confdefs.h + + + # Extract the first word of "cygpath", so it can be a program name with args. +set dummy cygpath; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if ${ac_cv_prog_CYGPATH+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test -n "$CYGPATH"; then + ac_cv_prog_CYGPATH="$CYGPATH" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if as_fn_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_CYGPATH="cygpath -m" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + test -z "$ac_cv_prog_CYGPATH" && ac_cv_prog_CYGPATH="echo" +fi +fi +CYGPATH=$ac_cv_prog_CYGPATH +if test -n "$CYGPATH"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CYGPATH" >&5 +$as_echo "$CYGPATH" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + + SHLIB_SUFFIX=".dll" + + # MACHINE is IX86 for LINK, but this is used by the manifest, + # which requires x86|amd64|ia64. + MACHINE="X86" + + if test "$GCC" = "yes"; then + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for cross-compile version of gcc" >&5 +$as_echo_n "checking for cross-compile version of gcc... " >&6; } +if ${ac_cv_cross+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #ifndef _WIN32 + #error cross-compiler + #endif + +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_cross=no +else + ac_cv_cross=yes +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_cross" >&5 +$as_echo "$ac_cv_cross" >&6; } + + if test "$ac_cv_cross" = "yes"; then + case "$do64bit" in + amd64|x64|yes) + CC="x86_64-w64-mingw32-gcc" + LD="x86_64-w64-mingw32-ld" + AR="x86_64-w64-mingw32-ar" + RANLIB="x86_64-w64-mingw32-ranlib" + RC="x86_64-w64-mingw32-windres" + ;; + *) + CC="i686-w64-mingw32-gcc" + LD="i686-w64-mingw32-ld" + AR="i686-w64-mingw32-ar" + RANLIB="i686-w64-mingw32-ranlib" + RC="i686-w64-mingw32-windres" + ;; + esac + fi + fi + + # Check for a bug in gcc's windres that causes the + # compile to fail when a Windows native path is + # passed into windres. The mingw toolchain requires + # Windows native paths while Cygwin should work + # with both. Avoid the bug by passing a POSIX + # path when using the Cygwin toolchain. + + if test "$GCC" = "yes" && test "$CYGPATH" != "echo" ; then + conftest=/tmp/conftest.rc + echo "STRINGTABLE BEGIN" > $conftest + echo "101 \"name\"" >> $conftest + echo "END" >> $conftest + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for Windows native path bug in windres" >&5 +$as_echo_n "checking for Windows native path bug in windres... " >&6; } + cyg_conftest=`$CYGPATH $conftest` + if { ac_try='$RC -o conftest.res.o $cyg_conftest' + { { eval echo "\"\$as_me\":${as_lineno-$LINENO}: \"$ac_try\""; } >&5 + (eval $ac_try) 2>&5 + ac_status=$? + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; }; } ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } + else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } + CYGPATH=echo + fi + conftest= + cyg_conftest= + fi + + if test "$CYGPATH" = "echo"; then + DEPARG='"$<"' + else + DEPARG='"$(shell $(CYGPATH) $<)"' + fi + + # set various compiler flags depending on whether we are using gcc or cl + + if test "${GCC}" = "yes" ; then + extra_cflags="-pipe" + extra_ldflags="-pipe -static-libgcc" + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for mingw32 version of gcc" >&5 +$as_echo_n "checking for mingw32 version of gcc... " >&6; } +if ${ac_cv_win32+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #ifdef _WIN32 + #error win32 + #endif + +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + ac_cv_win32=no +else + ac_cv_win32=yes +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_win32" >&5 +$as_echo "$ac_cv_win32" >&6; } + if test "$ac_cv_win32" != "yes"; then + as_fn_error $? "${CC} cannot produce win32 executables." "$LINENO" 5 + fi + + hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -mwindows -municode -Dmain=xxmain" + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for working -municode linker flag" >&5 +$as_echo_n "checking for working -municode linker flag... " >&6; } +if ${ac_cv_municode+:} false; then : + $as_echo_n "(cached) " >&6 +else + +# ac_fn_c_try_link LINENO +# ----------------------- +# Try to link conftest.$ac_ext, and return whether this succeeded. +ac_fn_c_try_link () +{ + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + rm -f conftest.$ac_objext conftest$ac_exeext + if { { ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\"" +$as_echo "$ac_try_echo"; } >&5 + (eval "$ac_link") 2>conftest.err + ac_status=$? + if test -s conftest.err; then + grep -v '^ *+' conftest.err >conftest.er1 + cat conftest.er1 >&5 + mv -f conftest.er1 conftest.err + fi + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 + test $ac_status = 0; } && { + test -z "$ac_c_werror_flag" || + test ! -s conftest.err + } && test -s conftest$ac_exeext && { + test "$cross_compiling" = yes || + test -x conftest$ac_exeext + }; then : + ac_retval=0 +else + $as_echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=1 +fi + # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information + # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would + # interfere with the next link command; also delete a directory that is + # left behind by Apple's compiler. We do this before executing the actions. + rm -rf conftest.dSYM conftest_ipa8_conftest.oo + eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + +} # ac_fn_c_try_link +cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #include <windows.h> + int APIENTRY wWinMain(HINSTANCE a, HINSTANCE b, LPWSTR c, int d) {return 0;} + +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_link "$LINENO"; then : + ac_cv_municode=yes +else + ac_cv_municode=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_municode" >&5 +$as_echo "$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 + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking compiler flags" >&5 +$as_echo_n "checking compiler flags... " >&6; } + if test "${GCC}" = "yes" ; then + SHLIB_LD="" + 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' + RC_OUT=-o + RC_TYPE= + RC_INCLUDE=--include + RC_DEFINE=--define + RES=res.o + MAKE_LIB="\${STLIB_LD} \$@" + MAKE_STUB_LIB="\${STLIB_LD} \$@" + POST_MAKE_LIB="\${RANLIB} \$@" + MAKE_EXE="\${CC} -o \$@" + LIBPREFIX="lib" + + if test "${SHARED_BUILD}" = "0" ; then + # static + { $as_echo "$as_me:${as_lineno-$LINENO}: result: using static flags" >&5 +$as_echo "using static flags" >&6; } + runtime= + LIBRARIES="\${STATIC_LIBRARIES}" + EXESUFFIX="s\${DBGX}.exe" + else + # dynamic + { $as_echo "$as_me:${as_lineno-$LINENO}: result: using shared flags" >&5 +$as_echo "using shared flags" >&6; } + + # ad-hoc check to see if CC supports -shared. + if "${CC}" -shared 2>&1 | egrep ': -shared not supported' >/dev/null; then + as_fn_error $? "${CC} does not support the -shared option. + You will need to upgrade to a newer version of the toolchain." "$LINENO" 5 + fi + + runtime= + # Add SHLIB_LD_LIBS to the Make rule, not here. + + 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 -Wwrite-strings -Wsign-compare -Wdeclaration-after-statement" + LDFLAGS_DEBUG= + LDFLAGS_OPTIMIZE= + + # Specify the CC output file names based on the target name + CC_OBJNAME="-o \$@" + CC_EXENAME="-o \$@" + + # Specify linker flags depending on the type of app being + # built -- Console vs. Window. + # + # ORIGINAL COMMENT: + # We need to pass -e _WinMain@16 so that ld will use + # WinMain() instead of main() as the entry point. We can't + # use autoconf to check for this case since it would need + # to run an executable and that does not work when + # cross compiling. Remove this -e workaround once we + # require a gcc that does not have this bug. + # + # MK NOTE: Tk should use a different mechanism. This causes + # interesting problems, such as wish dying at startup. + #LDFLAGS_WINDOW="-mwindows -e _WinMain@16 ${extra_ldflags}" + LDFLAGS_CONSOLE="-mconsole ${extra_ldflags}" + LDFLAGS_WINDOW="-mwindows ${extra_ldflags}" + + case "$do64bit" in + amd64|x64|yes) + MACHINE="AMD64" ; # assume AMD64 as default 64-bit build + { $as_echo "$as_me:${as_lineno-$LINENO}: result: Using 64-bit $MACHINE mode" >&5 +$as_echo " Using 64-bit $MACHINE mode" >&6; } + ;; + ia64) + MACHINE="IA64" + { $as_echo "$as_me:${as_lineno-$LINENO}: result: Using 64-bit $MACHINE mode" >&5 +$as_echo " Using 64-bit $MACHINE mode" >&6; } + ;; + *) + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #ifndef _WIN64 + #error 32-bit + #endif + +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + tcl_win_64bit=yes +else + tcl_win_64bit=no + +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + if test "$tcl_win_64bit" = "yes" ; then + do64bit=amd64 + MACHINE="AMD64" + { $as_echo "$as_me:${as_lineno-$LINENO}: result: Using 64-bit $MACHINE mode" >&5 +$as_echo " Using 64-bit $MACHINE mode" >&6; } + fi + ;; + esac + else + if test "${SHARED_BUILD}" = "0" ; then + # static + { $as_echo "$as_me:${as_lineno-$LINENO}: result: using static flags" >&5 +$as_echo "using static flags" >&6; } + runtime=-MT + LIBRARIES="\${STATIC_LIBRARIES}" + EXESUFFIX="s\${DBGX}.exe" + else + # dynamic + { $as_echo "$as_me:${as_lineno-$LINENO}: result: using shared flags" >&5 +$as_echo "using shared flags" >&6; } + runtime=-MD + # Add SHLIB_LD_LIBS to the Make rule, not here. + LIBRARIES="\${SHARED_LIBRARIES}" + EXESUFFIX="\${DBGX}.exe" + case "x`echo \${VisualStudioVersion}`" in + x1[4-9]*) + lflags="${lflags} -nodefaultlib:libucrt.lib" + ;; + *) + ;; + 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. + # This magic is based on MS Platform SDK for Win2003 SP1 - hobbs + if test "$do64bit" != "no" ; then + if test "x${MSSDK}x" = "xx" ; then + MSSDK="C:/Progra~1/Microsoft Platform SDK" + fi + MSSDK=`echo "$MSSDK" | sed -e 's!\\\!/!g'` + PATH64="" + case "$do64bit" in + amd64|x64|yes) + MACHINE="AMD64" ; # assume AMD64 as default 64-bit build + PATH64="${MSSDK}/Bin/Win64/x86/AMD64" + ;; + ia64) + MACHINE="IA64" + PATH64="${MSSDK}/Bin/Win64" + ;; + esac + if test ! -d "${PATH64}" ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Could not find 64-bit $MACHINE SDK" >&5 +$as_echo "$as_me: WARNING: Could not find 64-bit $MACHINE SDK" >&2;} + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: result: Using 64-bit $MACHINE mode" >&5 +$as_echo " Using 64-bit $MACHINE mode" >&6; } + fi + + LIBS="netapi32.lib kernel32.lib user32.lib advapi32.lib userenv.lib ws2_32.lib" + + case "x`echo \${VisualStudioVersion}`" in + x1[4-9]*) + LIBS="$LIBS ucrt.lib" + ;; + *) + ;; + esac + + if test "$do64bit" != "no" ; then + # The space-based-path will work for the Makefile, but will + # not work if AC_TRY_COMPILE is called. TEA has the + # TEA_PATH_NOSPACE to avoid this issue. + # Check if _WIN64 is already recognized, and if so we don't + # need to modify CC. + ac_fn_c_check_decl "$LINENO" "_WIN64" "ac_cv_have_decl__WIN64" "$ac_includes_default" +if test "x$ac_cv_have_decl__WIN64" = xyes; then : + +else + CC="\"${PATH64}/cl.exe\" -I\"${MSSDK}/Include\" \ + -I\"${MSSDK}/Include/crt\" \ + -I\"${MSSDK}/Include/crt/sys\"" +fi + + RC="\"${MSSDK}/bin/rc.exe\"" + CFLAGS_DEBUG="-nologo -Zi -Od ${runtime}d" + # Do not use -O2 for Win64 - this has proved buggy in code gen. + CFLAGS_OPTIMIZE="-nologo -O1 ${runtime}" + lflags="${lflags} -nologo -MACHINE:${MACHINE} -LIBPATH:\"${MSSDK}/Lib/${MACHINE}\"" + LINKBIN="\"${PATH64}/link.exe\"" + # Avoid 'unresolved external symbol __security_cookie' errors. + # c.f. http://support.microsoft.com/?id=894573 + LIBS="$LIBS bufferoverflowU.lib" + else + RC="rc" + # -Od - no optimization + # -WX - warnings as errors + CFLAGS_DEBUG="-nologo -Z7 -Od -WX ${runtime}d" + # -O2 - create fast code (/Og /Oi /Ot /Oy /Ob2 /Gs /GF /Gy) + CFLAGS_OPTIMIZE="-nologo -O2 ${runtime}" + lflags="${lflags} -nologo" + LINKBIN="link" + fi + + if test "$doWince" != "no" ; then + # Set defaults for common evc4/PPC2003 setup + # Currently Tcl requires 300+, possibly 420+ for sockets + CEVERSION=420; # could be 211 300 301 400 420 ... + TARGETCPU=ARMV4; # could be ARMV4 ARM MIPS SH3 X86 ... + ARCH=ARM; # could be ARM MIPS X86EM ... + PLATFORM="Pocket PC 2003"; # or "Pocket PC 2002" + if test "$doWince" != "yes"; then + # If !yes then the user specified something + # Reset ARCH to allow user to skip specifying it + ARCH= + eval `echo $doWince | awk -F "," '{ \ + if (length($1)) { printf "CEVERSION=\"%s\"\n", $1; \ + if ($1 < 400) { printf "PLATFORM=\"Pocket PC 2002\"\n" } }; \ + if (length($2)) { printf "TARGETCPU=\"%s\"\n", toupper($2) }; \ + if (length($3)) { printf "ARCH=\"%s\"\n", toupper($3) }; \ + if (length($4)) { printf "PLATFORM=\"%s\"\n", $4 }; \ + }'` + if test "x${ARCH}" = "x" ; then + ARCH=$TARGETCPU; + fi + fi + OSVERSION=WCE$CEVERSION; + if test "x${WCEROOT}" = "x" ; then + WCEROOT="C:/Program Files/Microsoft eMbedded C++ 4.0" + if test ! -d "${WCEROOT}" ; then + WCEROOT="C:/Program Files/Microsoft eMbedded Tools" + fi + fi + if test "x${SDKROOT}" = "x" ; then + SDKROOT="C:/Program Files/Windows CE Tools" + if test ! -d "${SDKROOT}" ; then + SDKROOT="C:/Windows CE Tools" + fi + fi + # The space-based-path will work for the Makefile, but will + # not work if AC_TRY_COMPILE is called. + WCEROOT=`echo "$WCEROOT" | sed -e 's!\\\!/!g'` + SDKROOT=`echo "$SDKROOT" | sed -e 's!\\\!/!g'` + CELIB_DIR=`echo "$CELIB_DIR" | sed -e 's!\\\!/!g'` + if test ! -d "${CELIB_DIR}/inc"; then + as_fn_error $? "Invalid celib directory \"${CELIB_DIR}\"" "$LINENO" 5 + fi + if test ! -d "${SDKROOT}/${OSVERSION}/${PLATFORM}/Lib/${TARGETCPU}"\ + -o ! -d "${WCEROOT}/EVC/${OSVERSION}/bin"; then + as_fn_error $? "could not find PocketPC SDK or target compiler to enable WinCE mode $CEVERSION,$TARGETCPU,$ARCH,$PLATFORM" "$LINENO" 5 + else + CEINCLUDE="${SDKROOT}/${OSVERSION}/${PLATFORM}/include" + if test -d "${CEINCLUDE}/${TARGETCPU}" ; then + CEINCLUDE="${CEINCLUDE}/${TARGETCPU}" + fi + CELIBPATH="${SDKROOT}/${OSVERSION}/${PLATFORM}/Lib/${TARGETCPU}" + fi + fi + + if test "$doWince" != "no" ; then + CEBINROOT="${WCEROOT}/EVC/${OSVERSION}/bin" + if test "${TARGETCPU}" = "X86"; then + CC="${CEBINROOT}/cl.exe" + else + CC="${CEBINROOT}/cl${ARCH}.exe" + fi + CC="\"${CC}\" -I\"${CELIB_DIR}/inc\" -I\"${CEINCLUDE}\"" + RC="\"${WCEROOT}/Common/EVC/bin/rc.exe\"" + arch=`echo ${ARCH} | awk '{print tolower($0)}'` + defs="${ARCH} _${ARCH}_ ${arch} PALM_SIZE _MT _DLL _WINDOWS" + for i in $defs ; do + cat >>confdefs.h <<_ACEOF +#define $i 1 +_ACEOF + + done +# if test "${ARCH}" = "X86EM"; then +# AC_DEFINE_UNQUOTED(_WIN32_WCE_EMULATION) +# fi + cat >>confdefs.h <<_ACEOF +#define _WIN32_WCE $CEVERSION +_ACEOF + + cat >>confdefs.h <<_ACEOF +#define UNDER_CE $CEVERSION +_ACEOF + + CFLAGS_DEBUG="-nologo -Zi -Od" + CFLAGS_OPTIMIZE="-nologo -O2" + lversion=`echo ${CEVERSION} | sed -e 's/\(.\)\(..\)/\1\.\2/'` + lflags="-nodefaultlib -MACHINE:${ARCH} -LIBPATH:\"${CELIBPATH}\" -subsystem:windowsce,${lversion} -nologo" + LINKBIN="\"${CEBINROOT}/link.exe\"" + + if test "${CEVERSION}" -lt 400 ; then + LIBS="coredll.lib corelibc.lib winsock.lib" + else + LIBS="coredll.lib corelibc.lib ws2.lib" + fi + # celib currently stuck at wce300 status + #LIBS="$LIBS \${CELIB_DIR}/wince-${ARCH}-pocket-${OSVERSION}-release/celib.lib" + LIBS="$LIBS \"\${CELIB_DIR}/wince-${ARCH}-pocket-wce300-release/celib.lib\"" + LIBS_GUI="commctrl.lib commdlg.lib" + else + LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib uuid.lib" + 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 + RC_TYPE=-r + RC_INCLUDE=-i + RC_DEFINE=-d + RES=res + MAKE_LIB="\${STLIB_LD} -out:\$@" + MAKE_STUB_LIB="\${STLIB_LD} -nodefaultlib -out:\$@" + POST_MAKE_LIB= + MAKE_EXE="\${CC} -Fe\$@" + LIBPREFIX="" + + CFLAGS_DEBUG="${CFLAGS_DEBUG} -D_CRT_SECURE_NO_DEPRECATE -D_CRT_NONSTDC_NO_DEPRECATE" + CFLAGS_OPTIMIZE="${CFLAGS_OPTIMIZE} -D_CRT_SECURE_NO_DEPRECATE -D_CRT_NONSTDC_NO_DEPRECATE" + + EXTRA_CFLAGS="" + CFLAGS_WARNING="-W3" + LDFLAGS_DEBUG="-debug" + LDFLAGS_OPTIMIZE="-release" + + # Specify the CC output file names based on the target name + CC_OBJNAME="-Fo\$@" + CC_EXENAME="-Fe\"\$(shell \$(CYGPATH) '\$@')\"" + + # Specify linker flags depending on the type of app being + # built -- Console vs. Window. + if test "$doWince" != "no" -a "${TARGETCPU}" != "X86"; then + LDFLAGS_CONSOLE="-link ${lflags}" + LDFLAGS_WINDOW=${LDFLAGS_CONSOLE} + else + LDFLAGS_CONSOLE="-link -subsystem:console ${lflags}" + LDFLAGS_WINDOW="-link -subsystem:windows ${lflags}" + fi + fi + + if test "$do64bit" != "no" ; then + $as_echo "#define TCL_CFG_DO64BIT 1" >>confdefs.h + + fi + + if test "${GCC}" = "yes" ; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for SEH support in compiler" >&5 +$as_echo_n "checking for SEH support in compiler... " >&6; } +if ${tcl_cv_seh+:} false; then : + $as_echo_n "(cached) " >&6 +else + if test "$cross_compiling" = yes; then : + tcl_cv_seh=no +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #define WIN32_LEAN_AND_MEAN + #include <windows.h> + #undef WIN32_LEAN_AND_MEAN + + int main(int argc, char** argv) { + int a, b = 0; + __try { + a = 666 / b; + } + __except (EXCEPTION_EXECUTE_HANDLER) { + return 0; + } + return 1; + } + +_ACEOF +if ac_fn_c_try_run "$LINENO"; then : + tcl_cv_seh=yes +else + tcl_cv_seh=no +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext \ + conftest.$ac_objext conftest.beam conftest.$ac_ext +fi + + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_seh" >&5 +$as_echo "$tcl_cv_seh" >&6; } + if test "$tcl_cv_seh" = "no" ; then + +$as_echo "#define HAVE_NO_SEH 1" >>confdefs.h + + fi + + # + # Check to see if the excpt.h include file provided contains the + # definition for EXCEPTION_DISPOSITION; if not, which is the case + # with Cygwin's version as of 2002-04-10, define it to be int, + # sufficient for getting the current code to work. + # + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for EXCEPTION_DISPOSITION support in include files" >&5 +$as_echo_n "checking for EXCEPTION_DISPOSITION support in include files... " >&6; } +if ${tcl_cv_eh_disposition+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +# define WIN32_LEAN_AND_MEAN +# include <windows.h> +# undef WIN32_LEAN_AND_MEAN + +int +main () +{ + + EXCEPTION_DISPOSITION x; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + tcl_cv_eh_disposition=yes +else + tcl_cv_eh_disposition=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_eh_disposition" >&5 +$as_echo "$tcl_cv_eh_disposition" >&6; } + if test "$tcl_cv_eh_disposition" = "no" ; then + +$as_echo "#define EXCEPTION_DISPOSITION int" >>confdefs.h + + fi + + # Check to see if winnt.h defines CHAR, SHORT, and LONG + # even if VOID has already been #defined. The win32api + # used by mingw and cygwin is known to do this. + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for winnt.h that ignores VOID define" >&5 +$as_echo_n "checking for winnt.h that ignores VOID define... " >&6; } +if ${tcl_cv_winnt_ignore_void+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + + #define VOID void + #define WIN32_LEAN_AND_MEAN + #include <windows.h> + #undef WIN32_LEAN_AND_MEAN + +int +main () +{ + + CHAR c; + SHORT s; + LONG l; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + tcl_cv_winnt_ignore_void=yes +else + tcl_cv_winnt_ignore_void=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_winnt_ignore_void" >&5 +$as_echo "$tcl_cv_winnt_ignore_void" >&6; } + if test "$tcl_cv_winnt_ignore_void" = "yes" ; then + +$as_echo "#define HAVE_WINNT_IGNORE_VOID 1" >>confdefs.h + + fi + + # See if the compiler supports casting to a union type. + # This is used to stop gcc from printing a compiler + # warning when initializing a union member. + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for cast to union support" >&5 +$as_echo_n "checking for cast to union support... " >&6; } +if ${tcl_cv_cast_to_union+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +int +main () +{ + + union foo { int i; double d; }; + union foo f = (union foo) (int) 0; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + tcl_cv_cast_to_union=yes +else + tcl_cv_cast_to_union=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cast_to_union" >&5 +$as_echo "$tcl_cv_cast_to_union" >&6; } + if test "$tcl_cv_cast_to_union" = "yes"; then + +$as_echo "#define HAVE_CAST_TO_UNION 1" >>confdefs.h + + fi + fi + + # DL_LIBS is empty, but then we match the Unix version + + + + + + +# Cross-compiling +case ${host_alias} in +*mingw32*) + TCL_EXE="tclsh" + ;; +*) + TCL_EXE="TCL_LIBRARY=\"\${LIBRARY_DIR}\"; export TCL_LIBRARY; ./\${TCLSH}" + ;; +esac + +#------------------------------------------------------------------------ +# Add stuff for zlib; note that this is mostly done in the makefile now +# as we just assume that the platform hasn't got a usable z.lib +#------------------------------------------------------------------------ + +if test "${enable_shared+set}" = "set"; then : + + enableval="$enable_shared" + tcl_ok=$enableval + +else + + tcl_ok=yes + +fi +if test "$tcl_ok" = "yes"; then : + + ZLIB_DLL_FILE=\${ZLIB_DLL_FILE} + + if test "$do64bit" = "yes"; then : + + if test "$GCC" == "yes"; then : + + ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64/libz.dll.a + + +else + + ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64/zdll.lib + + +fi + +else + + ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win32/zdll.lib + + +fi + +else + + ZLIB_OBJS=\${ZLIB_OBJS} + + +fi + +$as_echo "#define HAVE_ZLIB 1" >>confdefs.h + + +ac_fn_c_check_type "$LINENO" "intptr_t" "ac_cv_type_intptr_t" "$ac_includes_default" +if test "x$ac_cv_type_intptr_t" = xyes; then : + + +$as_echo "#define HAVE_INTPTR_T 1" >>confdefs.h + +else + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for pointer-size signed integer type" >&5 +$as_echo_n "checking for pointer-size signed integer type... " >&6; } +if ${tcl_cv_intptr_t+:} false; then : + $as_echo_n "(cached) " >&6 +else + + for tcl_cv_intptr_t in "int" "long" "long long" none; do + if test "$tcl_cv_intptr_t" != none; then + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$ac_includes_default +int +main () +{ +static int test_array [1 - 2 * !(sizeof (void *) <= sizeof ($tcl_cv_intptr_t))]; +test_array [0] = 0; +return test_array [0]; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + tcl_ok=yes +else + tcl_ok=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + test "$tcl_ok" = yes && break; fi + done +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_intptr_t" >&5 +$as_echo "$tcl_cv_intptr_t" >&6; } + if test "$tcl_cv_intptr_t" != none; then + +cat >>confdefs.h <<_ACEOF +#define intptr_t $tcl_cv_intptr_t +_ACEOF + + fi + +fi + +ac_fn_c_check_type "$LINENO" "uintptr_t" "ac_cv_type_uintptr_t" "$ac_includes_default" +if test "x$ac_cv_type_uintptr_t" = xyes; then : + + +$as_echo "#define HAVE_UINTPTR_T 1" >>confdefs.h + +else + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for pointer-size unsigned integer type" >&5 +$as_echo_n "checking for pointer-size unsigned integer type... " >&6; } +if ${tcl_cv_uintptr_t+:} false; then : + $as_echo_n "(cached) " >&6 +else + + for tcl_cv_uintptr_t in "unsigned int" "unsigned long" "unsigned long long" \ + none; do + if test "$tcl_cv_uintptr_t" != none; then + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ +$ac_includes_default +int +main () +{ +static int test_array [1 - 2 * !(sizeof (void *) <= sizeof ($tcl_cv_uintptr_t))]; +test_array [0] = 0; +return test_array [0]; + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + tcl_ok=yes +else + tcl_ok=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + test "$tcl_ok" = yes && break; fi + done +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_uintptr_t" >&5 +$as_echo "$tcl_cv_uintptr_t" >&6; } + if test "$tcl_cv_uintptr_t" != none; then + +cat >>confdefs.h <<_ACEOF +#define uintptr_t $tcl_cv_uintptr_t +_ACEOF + + fi + +fi + + +#-------------------------------------------------------------------- +# Perform additinal compiler tests. +#-------------------------------------------------------------------- + +# See if declarations like FINDEX_INFO_LEVELS are +# missing from winbase.h. This is known to be +# a problem with VC++ 5.2. + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for FINDEX_INFO_LEVELS in winbase.h" >&5 +$as_echo_n "checking for FINDEX_INFO_LEVELS in winbase.h... " >&6; } +if ${tcl_cv_findex_enums+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* 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 +if ac_fn_c_try_compile "$LINENO"; then : + tcl_cv_findex_enums=yes +else + tcl_cv_findex_enums=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_findex_enums" >&5 +$as_echo "$tcl_cv_findex_enums" >&6; } +if test "$tcl_cv_findex_enums" = "no"; then + +$as_echo "#define HAVE_NO_FINDEX_ENUMS 1" >>confdefs.h + +fi + +# See if the compiler supports intrinsics. + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for intrinsics support in compiler" >&5 +$as_echo_n "checking for intrinsics support in compiler... " >&6; } +if ${tcl_cv_intrinsics+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* 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 +if ac_fn_c_try_link "$LINENO"; then : + tcl_cv_intrinsics=yes +else + tcl_cv_intrinsics=no +fi +rm -f core conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_intrinsics" >&5 +$as_echo "$tcl_cv_intrinsics" >&6; } +if test "$tcl_cv_intrinsics" = "yes"; then + +$as_echo "#define HAVE_INTRIN_H 1" >>confdefs.h + +fi + +# See if the <wspiapi.h> header file is present + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for wspiapi.h" >&5 +$as_echo_n "checking for wspiapi.h... " >&6; } +if ${tcl_cv_wspiapi_h+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +#include <wspiapi.h> + +int +main () +{ + + ; + return 0; +} +_ACEOF +if ac_fn_c_try_compile "$LINENO"; then : + tcl_cv_wspiapi_h=yes +else + tcl_cv_wspiapi_h=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_wspiapi_h" >&5 +$as_echo "$tcl_cv_wspiapi_h" >&6; } +if test "$tcl_cv_wspiapi_h" = "yes"; then + +$as_echo "#define HAVE_WSPIAPI_H 1" >>confdefs.h + +fi + +# See if declarations like FINDEX_INFO_LEVELS are +# missing from winbase.h. This is known to be +# a problem with VC++ 5.2. + +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for FINDEX_INFO_LEVELS in winbase.h" >&5 +$as_echo_n "checking for FINDEX_INFO_LEVELS in winbase.h... " >&6; } +if ${tcl_cv_findex_enums+:} false; then : + $as_echo_n "(cached) " >&6 +else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* 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 +if ac_fn_c_try_compile "$LINENO"; then : + tcl_cv_findex_enums=yes +else + tcl_cv_findex_enums=no +fi +rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext + +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_findex_enums" >&5 +$as_echo "$tcl_cv_findex_enums" >&6; } +if test "$tcl_cv_findex_enums" = "no"; then + +$as_echo "#define HAVE_NO_FINDEX_ENUMS 1" >>confdefs.h + +fi + +#-------------------------------------------------------------------- +# Set the default compiler switches based on the --enable-symbols +# option. This macro depends on C flags, and should be called +# after SC_CONFIG_CFLAGS macro is called. +#-------------------------------------------------------------------- + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for build with symbols" >&5 +$as_echo_n "checking for build with symbols... " >&6; } + # Check whether --enable-symbols was given. +if test "${enable_symbols+set}" = set; then : + enableval=$enable_symbols; tcl_ok=$enableval +else + tcl_ok=no +fi + +# FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT. + if test "$tcl_ok" = "no"; then + CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)' + LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)' + DBGX="" + +$as_echo "#define NDEBUG 1" >>confdefs.h + + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } + + $as_echo "#define TCL_CFG_OPTIMIZED 1" >>confdefs.h + + else + CFLAGS_DEFAULT='$(CFLAGS_DEBUG)' + LDFLAGS_DEFAULT='$(LDFLAGS_DEBUG)' + DBGX=g + if test "$tcl_ok" = "yes"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes (standard debugging)" >&5 +$as_echo "yes (standard debugging)" >&6; } + fi + fi + + + + if test "$tcl_ok" = "mem" -o "$tcl_ok" = "all"; then + +$as_echo "#define TCL_MEM_DEBUG 1" >>confdefs.h + + fi + + if test "$tcl_ok" = "compile" -o "$tcl_ok" = "all"; then + +$as_echo "#define TCL_COMPILE_DEBUG 1" >>confdefs.h + + +$as_echo "#define TCL_COMPILE_STATS 1" >>confdefs.h + + fi + + if test "$tcl_ok" != "yes" -a "$tcl_ok" != "no"; then + if test "$tcl_ok" = "all"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: enabled symbols mem compile debugging" >&5 +$as_echo "enabled symbols mem compile debugging" >&6; } + else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: enabled $tcl_ok debugging" >&5 +$as_echo "enabled $tcl_ok debugging" >&6; } + fi + fi + + +TCL_DBGX=${DBGX} + +#-------------------------------------------------------------------- +# Embed the manifest if we can determine how +#-------------------------------------------------------------------- + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether to embed manifest" >&5 +$as_echo_n "checking whether to embed manifest... " >&6; } + # Check whether --enable-embedded-manifest was given. +if test "${enable_embedded_manifest+set}" = set; then : + enableval=$enable_embedded_manifest; embed_ok=$enableval +else + embed_ok=yes +fi + + + VC_MANIFEST_EMBED_DLL= + VC_MANIFEST_EMBED_EXE= + result=no + if test "$embed_ok" = "yes" -a "${SHARED_BUILD}" = "1" \ + -a "$GCC" != "yes" ; then + # Add the magic to embed the manifest into the dll/exe + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +/* end confdefs.h. */ + +#if defined(_MSC_VER) && _MSC_VER >= 1400 +print("manifest needed") +#endif + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "manifest needed" >/dev/null 2>&1; then : + + # Could do a CHECK_PROG for mt, but should always be with MSVC8+ + # Could add 'if test -f' check, but manifest should be created + # in this compiler case + # Add in a manifest argument that may be specified + # XXX Needs improvement so that the test for existence accounts + # XXX for a provided (known) manifest + VC_MANIFEST_EMBED_DLL="if test -f \$@.manifest ; then mt.exe -nologo -manifest \$@.manifest -outputresource:\$@\;2 ; fi" + VC_MANIFEST_EMBED_EXE="if test -f \$@.manifest ; then mt.exe -nologo -manifest \$@.manifest -outputresource:\$@\;1 ; fi" + result=yes + if test "x" != x ; then + result="yes ()" + fi + +fi +rm -f conftest* + + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $result" >&5 +$as_echo "$result" >&6; } + + + + +#------------------------------------------------------------------------ +# tclConfig.sh refers to this by a different name +#------------------------------------------------------------------------ + +TCL_SHARED_BUILD=${SHARED_BUILD} + +#-------------------------------------------------------------------- +# Perform final evaluations of variables with possible substitutions. +#-------------------------------------------------------------------- + +TCL_SHARED_LIB_SUFFIX="\${NODOT_VERSION}${DLLSUFFIX}" +TCL_UNSHARED_LIB_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}" +TCL_EXPORT_FILE_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}" + +eval "TCL_SRC_DIR=\"`cd $srcdir/..; $CYGPATH $(pwd)`\"" + +eval "TCL_DLL_FILE=tcl${VER}${DLLSUFFIX}" + +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}\"" +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}\"" + + +eval "DLLSUFFIX=${DLLSUFFIX}" +eval "LIBPREFIX=${LIBPREFIX}" +eval "LIBSUFFIX=${LIBSUFFIX}" +eval "EXESUFFIX=${EXESUFFIX}" + +CFG_TCL_SHARED_LIB_SUFFIX=${TCL_SHARED_LIB_SUFFIX} +CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX} +CFG_TCL_EXPORT_FILE_SUFFIX=${TCL_EXPORT_FILE_SUFFIX} + +#-------------------------------------------------------------------- +# Adjust the defines for how the resources are built depending +# on symbols and static vs. shared. +#-------------------------------------------------------------------- + +if test ${SHARED_BUILD} = 0 ; then + if test "${DBGX}" = "g"; then + RC_DEFINES="${RC_DEFINE} STATIC_BUILD ${RC_DEFINE} DEBUG" + else + RC_DEFINES="${RC_DEFINE} STATIC_BUILD" + fi +else + if test "${DBGX}" = "g"; then + RC_DEFINES="${RC_DEFINE} DEBUG" + else + RC_DEFINES="" + fi +fi + +#-------------------------------------------------------------------- +# The statements below define the symbol TCL_PACKAGE_PATH, which +# gives a list of directories that may contain packages. The list +# consists of one directory for machine-dependent binaries and +# another for platform-independent scripts. +#-------------------------------------------------------------------- + +if test "$prefix/lib" != "$libdir"; then + TCL_PACKAGE_PATH="${libdir} ${prefix}/lib" +else + TCL_PACKAGE_PATH="${prefix}/lib" +fi + +# The tclsh.exe.manifest requires these +# TCL_WIN_VERSION is the 4 dotted pair Windows version format which needs +# the release level, and must account for interim release versioning +case "$TCL_PATCH_LEVEL" in + *a*) TCL_RELEASE_LEVEL=0 ;; + *b*) TCL_RELEASE_LEVEL=1 ;; + *) TCL_RELEASE_LEVEL=2 ;; +esac +TCL_WIN_VERSION="$TCL_VERSION.$TCL_RELEASE_LEVEL.`echo $TCL_PATCH_LEVEL | tr -d ab.`" + +# X86|AMD64|IA64 for manifest + + + + + + + + + + + + + + + +# empty on win + + + + + + + + + + + + + + + + + +# win/tcl.m4 doesn't set (CFLAGS) + + + + + + + +# win/tcl.m4 doesn't set (LDFLAGS) + + + + + + + + + + + + + + + + + + + + + + + + + + + + +# empty on win, but needs sub'ing + + + + + + + + + + +# win only + + + + + + + + + + + + + + + +ac_config_files="$ac_config_files Makefile tclConfig.sh tcl.hpj tclsh.exe.manifest" + +cat >confcache <<\_ACEOF +# This file is a shell script that caches the results of configure +# tests run on this system so they can be shared between configure +# scripts and configure runs, see configure's option --config-cache. +# It is not useful on other systems. If it contains results you don't +# want to keep, you may remove or edit it. +# +# config.status only pays attention to the cache file if you give it +# the --recheck option to rerun configure. +# +# `ac_cv_env_foo' variables (set or unset) will be overridden when +# loading this file, other *unset* `ac_cv_foo' will be assigned the +# following values. + +_ACEOF + +# The following way of writing the cache mishandles newlines in values, +# but we know of no workaround that is simple, portable, and efficient. +# So, we kill variables containing newlines. +# Ultrix sh set writes to stderr and can't be redirected directly, +# and sets the high bit in the cache file unless we assign to the vars. +( + for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do + eval ac_val=\$$ac_var + case $ac_val in #( + *${as_nl}*) + case $ac_var in #( + *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5 +$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;; + esac + case $ac_var in #( + _ | IFS | as_nl) ;; #( + BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #( + *) { eval $ac_var=; unset $ac_var;} ;; + esac ;; + esac + done + + (set) 2>&1 | + case $as_nl`(ac_space=' '; set) 2>&1` in #( + *${as_nl}ac_space=\ *) + # `set' does not quote correctly, so add quotes: double-quote + # substitution turns \\\\ into \\, and sed turns \\ into \. + sed -n \ + "s/'/'\\\\''/g; + s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" + ;; #( + *) + # `set' quotes correctly as required by POSIX, so do not add quotes. + sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p" + ;; + esac | + sort +) | + sed ' + /^ac_cv_env_/b end + t clear + :clear + s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ + t end + s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ + :end' >>confcache +if diff "$cache_file" confcache >/dev/null 2>&1; then :; else + if test -w "$cache_file"; then + if test "x$cache_file" != "x/dev/null"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 +$as_echo "$as_me: updating cache $cache_file" >&6;} + if test ! -f "$cache_file" || test -h "$cache_file"; then + cat confcache >"$cache_file" + else + case $cache_file in #( + */* | ?:*) + mv -f confcache "$cache_file"$$ && + mv -f "$cache_file"$$ "$cache_file" ;; #( + *) + mv -f confcache "$cache_file" ;; + esac + fi + fi + else + { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 +$as_echo "$as_me: not updating unwritable cache $cache_file" >&6;} + fi +fi +rm -f confcache + +test "x$prefix" = xNONE && prefix=$ac_default_prefix +# Let make expand exec_prefix. +test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' + +# Transform confdefs.h into DEFS. +# Protect against shell expansion while executing Makefile rules. +# Protect against Makefile macro expansion. +# +# If the first sed substitution is executed (which looks for macros that +# take arguments), then branch to the quote section. Otherwise, +# look for a macro that doesn't take arguments. +ac_script=' +:mline +/\\$/{ + N + s,\\\n,, + b mline +} +t clear +:clear +s/^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*([^)]*)\)[ ]*\(.*\)/-D\1=\2/g +t quote +s/^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\)/-D\1=\2/g +t quote +b any +:quote +s/[ `~#$^&*(){}\\|;'\''"<>?]/\\&/g +s/\[/\\&/g +s/\]/\\&/g +s/\$/$$/g +H +:any +${ + g + s/^\n// + s/\n/ /g + p +} +' +DEFS=`sed -n "$ac_script" confdefs.h` + + +ac_libobjs= +ac_ltlibobjs= +U= +for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue + # 1. Remove the extension, and $U if already installed. + ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' + ac_i=`$as_echo "$ac_i" | sed "$ac_script"` + # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR + # will be set to the directory where LIBOBJS objects are built. + as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext" + as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo' +done +LIBOBJS=$ac_libobjs + +LTLIBOBJS=$ac_ltlibobjs + + + +: "${CONFIG_STATUS=./config.status}" +ac_write_fail=0 +ac_clean_files_save=$ac_clean_files +ac_clean_files="$ac_clean_files $CONFIG_STATUS" +{ $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5 +$as_echo "$as_me: creating $CONFIG_STATUS" >&6;} +as_write_fail=0 +cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1 +#! $SHELL +# Generated by $as_me. +# Run this file to recreate the current configuration. +# Compiler output produced by configure, useful for debugging +# configure, is in config.log if it exists. + +debug=false +ac_cs_recheck=false +ac_cs_silent=false + +SHELL=\${CONFIG_SHELL-$SHELL} +export SHELL +_ASEOF +cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1 +## -------------------- ## +## M4sh Initialization. ## +## -------------------- ## + +# Be more Bourne compatible +DUALCASE=1; export DUALCASE # for MKS sh +if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then : + emulate sh + NULLCMD=: + # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which + # is contrary to our usage. Disable this feature. + alias -g '${1+"$@"}'='"$@"' + setopt NO_GLOB_SUBST +else + case `(set -o) 2>/dev/null` in #( + *posix*) : + set -o posix ;; #( + *) : + ;; +esac +fi + + +as_nl=' +' +export as_nl +# Printing a long string crashes Solaris 7 /usr/bin/printf. +as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\' +as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo +as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo +# Prefer a ksh shell builtin over an external printf program on Solaris, +# but without wasting forks for bash or zsh. +if test -z "$BASH_VERSION$ZSH_VERSION" \ + && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='print -r --' + as_echo_n='print -rn --' +elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then + as_echo='printf %s\n' + as_echo_n='printf %s' +else + if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then + as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"' + as_echo_n='/usr/ucb/echo -n' + else + as_echo_body='eval expr "X$1" : "X\\(.*\\)"' + as_echo_n_body='eval + arg=$1; + case $arg in #( + *"$as_nl"*) + expr "X$arg" : "X\\(.*\\)$as_nl"; + arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;; + esac; + expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl" + ' + export as_echo_n_body + as_echo_n='sh -c $as_echo_n_body as_echo' + fi + export as_echo_body + as_echo='sh -c $as_echo_body as_echo' +fi + +# The user is always right. +if test "${PATH_SEPARATOR+set}" != set; then + PATH_SEPARATOR=: + (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && { + (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 || + PATH_SEPARATOR=';' + } +fi + + +# IFS +# We need space, tab and new line, in precisely that order. Quoting is +# there to prevent editors from complaining about space-tab. +# (If _AS_PATH_WALK were called with IFS unset, it would disable word +# splitting by setting IFS to empty value.) +IFS=" "" $as_nl" + +# Find who we are. Look in the path if we contain no directory separator. +as_myself= +case $0 in #(( + *[\\/]* ) as_myself=$0 ;; + *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break + done +IFS=$as_save_IFS + + ;; +esac +# We did not find ourselves, most probably we were run as `sh COMMAND' +# in which case we are not to be found in the path. +if test "x$as_myself" = x; then + as_myself=$0 +fi +if test ! -f "$as_myself"; then + $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2 + exit 1 +fi + +# Unset variables that we do not need and which cause bugs (e.g. in +# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1" +# suppresses any "Segmentation fault" message there. '((' could +# trigger a bug in pdksh 5.2.14. +for as_var in BASH_ENV ENV MAIL MAILPATH +do eval test x\${$as_var+set} = xset \ + && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || : +done +PS1='$ ' +PS2='> ' +PS4='+ ' + +# NLS nuisances. +LC_ALL=C +export LC_ALL +LANGUAGE=C +export LANGUAGE + +# CDPATH. +(unset CDPATH) >/dev/null 2>&1 && unset CDPATH + + +# as_fn_error STATUS ERROR [LINENO LOG_FD] +# ---------------------------------------- +# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are +# provided, also output the error to LOG_FD, referencing LINENO. Then exit the +# script with STATUS, using 1 if that was 0. +as_fn_error () +{ + as_status=$1; test $as_status -eq 0 && as_status=1 + if test "$4"; then + as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 + fi + $as_echo "$as_me: error: $2" >&2 + as_fn_exit $as_status +} # as_fn_error + + +# as_fn_set_status STATUS +# ----------------------- +# Set $? to STATUS, without forking. +as_fn_set_status () +{ + return $1 +} # as_fn_set_status + +# as_fn_exit STATUS +# ----------------- +# Exit the shell with STATUS, even in a "trap 0" or "set -e" context. +as_fn_exit () +{ + set +e + as_fn_set_status $1 + exit $1 +} # as_fn_exit + +# as_fn_unset VAR +# --------------- +# Portably unset VAR. +as_fn_unset () +{ + { eval $1=; unset $1;} +} +as_unset=as_fn_unset +# as_fn_append VAR VALUE +# ---------------------- +# Append the text in VALUE to the end of the definition contained in VAR. Take +# advantage of any shell optimizations that allow amortized linear growth over +# repeated appends, instead of the typical quadratic growth present in naive +# implementations. +if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then : + eval 'as_fn_append () + { + eval $1+=\$2 + }' +else + as_fn_append () + { + eval $1=\$$1\$2 + } +fi # as_fn_append + +# as_fn_arith ARG... +# ------------------ +# Perform arithmetic evaluation on the ARGs, and store the result in the +# global $as_val. Take advantage of shells that can avoid forks. The arguments +# must be portable across $(()) and expr. +if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then : + eval 'as_fn_arith () + { + as_val=$(( $* )) + }' +else + as_fn_arith () + { + as_val=`expr "$@" || test $? -eq 1` + } +fi # as_fn_arith + + +if expr a : '\(a\)' >/dev/null 2>&1 && + test "X`expr 00001 : '.*\(...\)'`" = X001; then + as_expr=expr +else + as_expr=false +fi + +if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then + as_basename=basename +else + as_basename=false +fi + +if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then + as_dirname=dirname +else + as_dirname=false +fi + +as_me=`$as_basename -- "$0" || +$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ + X"$0" : 'X\(//\)$' \| \ + X"$0" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X/"$0" | + sed '/^.*\/\([^/][^/]*\)\/*$/{ + s//\1/ + q + } + /^X\/\(\/\/\)$/{ + s//\1/ + q + } + /^X\/\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + +# Avoid depending upon Character Ranges. +as_cr_letters='abcdefghijklmnopqrstuvwxyz' +as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' +as_cr_Letters=$as_cr_letters$as_cr_LETTERS +as_cr_digits='0123456789' +as_cr_alnum=$as_cr_Letters$as_cr_digits + +ECHO_C= ECHO_N= ECHO_T= +case `echo -n x` in #((((( +-n*) + case `echo 'xy\c'` in + *c*) ECHO_T=' ';; # ECHO_T is single tab character. + xy) ECHO_C='\c';; + *) echo `echo ksh88 bug on AIX 6.1` > /dev/null + ECHO_T=' ';; + esac;; +*) + ECHO_N='-n';; +esac + +rm -f conf$$ conf$$.exe conf$$.file +if test -d conf$$.dir; then + rm -f conf$$.dir/conf$$.file +else + rm -f conf$$.dir + mkdir conf$$.dir 2>/dev/null +fi +if (echo >conf$$.file) 2>/dev/null; then + if ln -s conf$$.file conf$$ 2>/dev/null; then + as_ln_s='ln -s' + # ... but there are two gotchas: + # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail. + # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable. + # In both cases, we have to default to `cp -pR'. + ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe || + as_ln_s='cp -pR' + elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln + else + as_ln_s='cp -pR' + fi +else + as_ln_s='cp -pR' +fi +rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file +rmdir conf$$.dir 2>/dev/null + + +# as_fn_mkdir_p +# ------------- +# Create "$as_dir" as a directory, including parents if necessary. +as_fn_mkdir_p () +{ + + case $as_dir in #( + -*) as_dir=./$as_dir;; + esac + test -d "$as_dir" || eval $as_mkdir_p || { + as_dirs= + while :; do + case $as_dir in #( + *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'( + *) as_qdir=$as_dir;; + esac + as_dirs="'$as_qdir' $as_dirs" + as_dir=`$as_dirname -- "$as_dir" || +$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$as_dir" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + test -d "$as_dir" && break + done + test -z "$as_dirs" || eval "mkdir $as_dirs" + } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" + + +} # as_fn_mkdir_p +if mkdir -p . 2>/dev/null; then + as_mkdir_p='mkdir -p "$as_dir"' +else + test -d ./-p && rmdir ./-p + as_mkdir_p=false +fi + + +# as_fn_executable_p FILE +# ----------------------- +# Test if FILE is an executable regular file. +as_fn_executable_p () +{ + test -f "$1" && test -x "$1" +} # as_fn_executable_p +as_test_x='test -x' +as_executable_p=as_fn_executable_p + +# Sed expression to map a string onto a valid CPP name. +as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" + +# Sed expression to map a string onto a valid variable name. +as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" + + +exec 6>&1 +## ----------------------------------- ## +## Main body of $CONFIG_STATUS script. ## +## ----------------------------------- ## +_ASEOF +test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +# Save the log message, to keep $0 and so on meaningful, and to +# report actual input values of CONFIG_FILES etc. instead of their +# values after options handling. +ac_log=" +This file was extended by $as_me, which was +generated by GNU Autoconf 2.69. Invocation command line was + + CONFIG_FILES = $CONFIG_FILES + CONFIG_HEADERS = $CONFIG_HEADERS + CONFIG_LINKS = $CONFIG_LINKS + CONFIG_COMMANDS = $CONFIG_COMMANDS + $ $0 $@ + +on `(hostname || uname -n) 2>/dev/null | sed 1q` +" + +_ACEOF + +case $ac_config_files in *" +"*) set x $ac_config_files; shift; ac_config_files=$*;; +esac + + + +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +# Files that config.status was made for. +config_files="$ac_config_files" + +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +ac_cs_usage="\ +\`$as_me' instantiates files and other configuration actions +from templates according to the current configuration. Unless the files +and actions are specified as TAGs, all are instantiated by default. + +Usage: $0 [OPTION]... [TAG]... + + -h, --help print this help, then exit + -V, --version print version number and configuration settings, then exit + --config print configuration, then exit + -q, --quiet, --silent + do not print progress messages + -d, --debug don't remove temporary files + --recheck update $as_me by reconfiguring in the same conditions + --file=FILE[:TEMPLATE] + instantiate the configuration file FILE + +Configuration files: +$config_files + +Report bugs to the package provider." + +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" +ac_cs_version="\\ +config.status +configured by $0, generated by GNU Autoconf 2.69, + with options \\"\$ac_cs_config\\" + +Copyright (C) 2012 Free Software Foundation, Inc. +This config.status script is free software; the Free Software Foundation +gives unlimited permission to copy, distribute and modify it." + +ac_pwd='$ac_pwd' +srcdir='$srcdir' +test -n "\$AWK" || AWK=awk +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +# The default lists apply if the user does not specify any file. +ac_need_defaults=: +while test $# != 0 +do + case $1 in + --*=?*) + ac_option=`expr "X$1" : 'X\([^=]*\)='` + ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` + ac_shift=: + ;; + --*=) + ac_option=`expr "X$1" : 'X\([^=]*\)='` + ac_optarg= + ac_shift=: + ;; + *) + ac_option=$1 + ac_optarg=$2 + ac_shift=shift + ;; + esac + + case $ac_option in + # Handling of the options. + -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) + ac_cs_recheck=: ;; + --version | --versio | --versi | --vers | --ver | --ve | --v | -V ) + $as_echo "$ac_cs_version"; exit ;; + --config | --confi | --conf | --con | --co | --c ) + $as_echo "$ac_cs_config"; exit ;; + --debug | --debu | --deb | --de | --d | -d ) + debug=: ;; + --file | --fil | --fi | --f ) + $ac_shift + case $ac_optarg in + *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; + '') as_fn_error $? "missing file argument" ;; + esac + as_fn_append CONFIG_FILES " '$ac_optarg'" + ac_need_defaults=false;; + --he | --h | --help | --hel | -h ) + $as_echo "$ac_cs_usage"; exit ;; + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil | --si | --s) + ac_cs_silent=: ;; + + # This is an error. + -*) as_fn_error $? "unrecognized option: \`$1' +Try \`$0 --help' for more information." ;; + + *) as_fn_append ac_config_targets " $1" + ac_need_defaults=false ;; + + esac + shift +done + +ac_configure_extra_args= + +if $ac_cs_silent; then + exec 6>/dev/null + ac_configure_extra_args="$ac_configure_extra_args --silent" +fi + +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +if \$ac_cs_recheck; then + set X $SHELL '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion + shift + \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6 + CONFIG_SHELL='$SHELL' + export CONFIG_SHELL + exec "\$@" +fi + +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +exec 5>>config.log +{ + echo + sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX +## Running $as_me. ## +_ASBOX + $as_echo "$ac_log" +} >&5 + +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 + +# Handling of arguments. +for ac_config_target in $ac_config_targets +do + case $ac_config_target in + "Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;; + "tclConfig.sh") CONFIG_FILES="$CONFIG_FILES tclConfig.sh" ;; + "tcl.hpj") CONFIG_FILES="$CONFIG_FILES tcl.hpj" ;; + "tclsh.exe.manifest") CONFIG_FILES="$CONFIG_FILES tclsh.exe.manifest" ;; + + *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; + esac +done + + +# If the user did not use the arguments to specify the items to instantiate, +# then the envvar interface is used. Set only those that are not. +# We use the long form for the default assignment because of an extremely +# bizarre bug on SunOS 4.1.3. +if $ac_need_defaults; then + test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files +fi + +# Have a temporary directory for convenience. Make it in the build tree +# simply because there is no reason against having it here, and in addition, +# creating and moving files from /tmp can sometimes cause problems. +# Hook for its removal unless debugging. +# Note that there is a small window in which the directory will not be cleaned: +# after its creation but before its name has been assigned to `$tmp'. +$debug || +{ + tmp= ac_tmp= + trap 'exit_status=$? + : "${ac_tmp:=$tmp}" + { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status +' 0 + trap 'as_fn_exit 1' 1 2 13 15 +} +# Create a (secure) tmp directory for tmp files. + +{ + tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && + test -d "$tmp" +} || +{ + tmp=./conf$$-$RANDOM + (umask 077 && mkdir "$tmp") +} || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 +ac_tmp=$tmp + +# Set up the scripts for CONFIG_FILES section. +# No need to generate them if there are no CONFIG_FILES. +# This happens for instance with `./config.status config.h'. +if test -n "$CONFIG_FILES"; then + + +ac_cr=`echo X | tr X '\015'` +# On cygwin, bash can eat \r inside `` if the user requested igncr. +# But we know of no other shell where ac_cr would be empty at this +# point, so we can use a bashism as a fallback. +if test "x$ac_cr" = x; then + eval ac_cr=\$\'\\r\' +fi +ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' </dev/null 2>/dev/null` +if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then + ac_cs_awk_cr='\\r' +else + ac_cs_awk_cr=$ac_cr +fi + +echo 'BEGIN {' >"$ac_tmp/subs1.awk" && +_ACEOF + + +{ + echo "cat >conf$$subs.awk <<_ACEOF" && + echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && + echo "_ACEOF" +} >conf$$subs.sh || + as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 +ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` +ac_delim='%!_!# ' +for ac_last_try in false false false false false :; do + . ./conf$$subs.sh || + as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 + + ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` + if test $ac_delim_n = $ac_delim_num; then + break + elif $ac_last_try; then + as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 + else + ac_delim="$ac_delim!$ac_delim _$ac_delim!! " + fi +done +rm -f conf$$subs.sh + +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && +_ACEOF +sed -n ' +h +s/^/S["/; s/!.*/"]=/ +p +g +s/^[^!]*!// +:repl +t repl +s/'"$ac_delim"'$// +t delim +:nl +h +s/\(.\{148\}\)..*/\1/ +t more1 +s/["\\]/\\&/g; s/^/"/; s/$/\\n"\\/ +p +n +b repl +:more1 +s/["\\]/\\&/g; s/^/"/; s/$/"\\/ +p +g +s/.\{148\}// +t nl +:delim +h +s/\(.\{148\}\)..*/\1/ +t more2 +s/["\\]/\\&/g; s/^/"/; s/$/"/ +p +b +:more2 +s/["\\]/\\&/g; s/^/"/; s/$/"\\/ +p +g +s/.\{148\}// +t delim +' <conf$$subs.awk | sed ' +/^[^""]/{ + N + s/\n// +} +' >>$CONFIG_STATUS || ac_write_fail=1 +rm -f conf$$subs.awk +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +_ACAWK +cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && + for (key in S) S_is_set[key] = 1 + FS = "" + +} +{ + line = $ 0 + nfields = split(line, field, "@") + substed = 0 + len = length(field[1]) + for (i = 2; i < nfields; i++) { + key = field[i] + keylen = length(key) + if (S_is_set[key]) { + value = S[key] + line = substr(line, 1, len) "" value "" substr(line, len + keylen + 3) + len += length(value) + length(field[++i]) + substed = 1 + } else + len += 1 + keylen + } + + print line +} + +_ACAWK +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +if sed "s/$ac_cr//" < /dev/null > /dev/null 2>&1; then + sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" +else + cat +fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ + || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 +_ACEOF + +# VPATH may cause trouble with some makes, so we remove sole $(srcdir), +# ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and +# trailing colons and then remove the whole line if VPATH becomes empty +# (actually we leave an empty line to preserve line numbers). +if test "x$srcdir" = x.; then + ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ +h +s/// +s/^/:/ +s/[ ]*$/:/ +s/:\$(srcdir):/:/g +s/:\${srcdir}:/:/g +s/:@srcdir@:/:/g +s/^:*// +s/:*$// +x +s/\(=[ ]*\).*/\1/ +G +s/\n// +s/^[^=]*=[ ]*$// +}' +fi + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +fi # test -n "$CONFIG_FILES" + + +eval set X " :F $CONFIG_FILES " +shift +for ac_tag +do + case $ac_tag in + :[FHLC]) ac_mode=$ac_tag; continue;; + esac + case $ac_mode$ac_tag in + :[FHL]*:*);; + :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; + :[FH]-) ac_tag=-:-;; + :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; + esac + ac_save_IFS=$IFS + IFS=: + set x $ac_tag + IFS=$ac_save_IFS + shift + ac_file=$1 + shift + + case $ac_mode in + :L) ac_source=$1;; + :[FH]) + ac_file_inputs= + for ac_f + do + case $ac_f in + -) ac_f="$ac_tmp/stdin";; + *) # Look for the file first in the build tree, then in the source tree + # (if the path is not absolute). The absolute path cannot be DOS-style, + # because $ac_f cannot contain `:'. + test -f "$ac_f" || + case $ac_f in + [\\/$]*) false;; + *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; + esac || + as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; + esac + case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac + as_fn_append ac_file_inputs " '$ac_f'" + done + + # Let's still pretend it is `configure' which instantiates (i.e., don't + # use $as_me), people would be surprised to read: + # /* config.h. Generated by config.status. */ + configure_input='Generated from '` + $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g' + `' by configure.' + if test x"$ac_file" != x-; then + configure_input="$ac_file. $configure_input" + { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5 +$as_echo "$as_me: creating $ac_file" >&6;} + fi + # Neutralize special characters interpreted by sed in replacement strings. + case $configure_input in #( + *\&* | *\|* | *\\* ) + ac_sed_conf_input=`$as_echo "$configure_input" | + sed 's/[\\\\&|]/\\\\&/g'`;; #( + *) ac_sed_conf_input=$configure_input;; + esac + + case $ac_tag in + *:-:* | *:-) cat >"$ac_tmp/stdin" \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; + esac + ;; + esac + + ac_dir=`$as_dirname -- "$ac_file" || +$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$ac_file" : 'X\(//\)[^/]' \| \ + X"$ac_file" : 'X\(//\)$' \| \ + X"$ac_file" : 'X\(/\)' \| . 2>/dev/null || +$as_echo X"$ac_file" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ + s//\1/ + q + } + /^X\(\/\/\)[^/].*/{ + s//\1/ + q + } + /^X\(\/\/\)$/{ + s//\1/ + q + } + /^X\(\/\).*/{ + s//\1/ + q + } + s/.*/./; q'` + as_dir="$ac_dir"; as_fn_mkdir_p + ac_builddir=. + +case "$ac_dir" in +.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;; +*) + ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'` + # A ".." for each directory in $ac_dir_suffix. + ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'` + case $ac_top_builddir_sub in + "") ac_top_builddir_sub=. ac_top_build_prefix= ;; + *) ac_top_build_prefix=$ac_top_builddir_sub/ ;; + esac ;; +esac +ac_abs_top_builddir=$ac_pwd +ac_abs_builddir=$ac_pwd$ac_dir_suffix +# for backward compatibility: +ac_top_builddir=$ac_top_build_prefix + +case $srcdir in + .) # We are building in place. + ac_srcdir=. + ac_top_srcdir=$ac_top_builddir_sub + ac_abs_top_srcdir=$ac_pwd ;; + [\\/]* | ?:[\\/]* ) # Absolute name. + ac_srcdir=$srcdir$ac_dir_suffix; + ac_top_srcdir=$srcdir + ac_abs_top_srcdir=$srcdir ;; + *) # Relative name. + ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_build_prefix$srcdir + ac_abs_top_srcdir=$ac_pwd/$srcdir ;; +esac +ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix + + + case $ac_mode in + :F) + # + # CONFIG_FILE + # + +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +# If the template does not know about datarootdir, expand it. +# FIXME: This hack should be removed a few years after 2.60. +ac_datarootdir_hack=; ac_datarootdir_seen= +ac_sed_dataroot=' +/datarootdir/ { + p + q +} +/@datadir@/p +/@docdir@/p +/@infodir@/p +/@localedir@/p +/@mandir@/p' +case `eval "sed -n \"\$ac_sed_dataroot\" $ac_file_inputs"` in +*datarootdir*) ac_datarootdir_seen=yes;; +*@datadir@*|*@docdir@*|*@infodir@*|*@localedir@*|*@mandir@*) + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&5 +$as_echo "$as_me: WARNING: $ac_file_inputs seems to ignore the --datarootdir setting" >&2;} +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 + ac_datarootdir_hack=' + s&@datadir@&$datadir&g + s&@docdir@&$docdir&g + s&@infodir@&$infodir&g + s&@localedir@&$localedir&g + s&@mandir@&$mandir&g + s&\\\${datarootdir}&$datarootdir&g' ;; +esac +_ACEOF + +# Neutralize VPATH when `$srcdir' = `.'. +# Shell code in configure.ac might set extrasub. +# FIXME: do we really want to maintain this feature? +cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +ac_sed_extra="$ac_vpsub +$extrasub +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +:t +/@[a-zA-Z_][a-zA-Z_0-9]*@/!b +s|@configure_input@|$ac_sed_conf_input|;t t +s&@top_builddir@&$ac_top_builddir_sub&;t t +s&@top_build_prefix@&$ac_top_build_prefix&;t t +s&@srcdir@&$ac_srcdir&;t t +s&@abs_srcdir@&$ac_abs_srcdir&;t t +s&@top_srcdir@&$ac_top_srcdir&;t t +s&@abs_top_srcdir@&$ac_abs_top_srcdir&;t t +s&@builddir@&$ac_builddir&;t t +s&@abs_builddir@&$ac_abs_builddir&;t t +s&@abs_top_builddir@&$ac_abs_top_builddir&;t t +$ac_datarootdir_hack +" +eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ + >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + +test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && + { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && + { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ + "$ac_tmp/out"`; test -z "$ac_out"; } && + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' +which seems to be undefined. Please make sure it is defined" >&5 +$as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' +which seems to be undefined. Please make sure it is defined" >&2;} + + rm -f "$ac_tmp/stdin" + case $ac_file in + -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; + *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; + esac \ + || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + ;; + + + + esac + +done # for ac_tag + + +as_fn_exit 0 +_ACEOF +ac_clean_files=$ac_clean_files_save + +test $ac_write_fail = 0 || + as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 + + +# configure is writing to config.log, and then calls config.status. +# config.status does its own redirection, appending to config.log. +# Unfortunately, on DOS this fails, as config.log is still kept open +# by configure, so config.status won't be able to write to it; its +# output is simply discarded. So we exec the FD to /dev/null, +# effectively closing config.log, so it can be properly (re)opened and +# appended to by config.status. When coming back to configure, we +# need to make the FD available again. +if test "$no_create" != yes; then + ac_cs_success=: + ac_config_status_args= + test "$silent" = yes && + ac_config_status_args="$ac_config_status_args --quiet" + exec 5>/dev/null + $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false + exec 5>>config.log + # Use ||, not &&, to avoid exiting from the if with $? = 1, which + # would make configure fail if this is the last instruction. + $ac_cs_success || as_fn_exit 1 +fi +if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 +$as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;} +fi + + diff --git a/win/configure.ac b/win/configure.ac new file mode 100644 index 0000000..d03695c --- /dev/null +++ b/win/configure.ac @@ -0,0 +1,465 @@ +#! /bin/bash -norc +# This file is an input file used by the GNU "autoconf" program to +# generate the file "configure", which is run during Tcl installation +# to configure the system for the local environment. + +AC_INIT(../generic/tcl.h) +AC_PREREQ(2.69) + +# The following define is needed when building with Cygwin since newer +# versions of autoconf incorrectly set SHELL to /bin/bash instead of +# /bin/sh. The bash shell seems to suffer from some strange failures. +SHELL=/bin/sh + +TCL_VERSION=8.7 +TCL_MAJOR_VERSION=8 +TCL_MINOR_VERSION=7 +TCL_PATCH_LEVEL="a2" +VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION + +TCL_DDE_VERSION=1.4 +TCL_DDE_MAJOR_VERSION=1 +TCL_DDE_MINOR_VERSION=4 +DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION + +TCL_REG_VERSION=1.3 +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 +#------------------------------------------------------------------------ + +if test "${prefix}" = "NONE"; then + prefix=/usr/local +fi +if test "${exec_prefix}" = "NONE"; then + exec_prefix=$prefix +fi +# libdir must be a fully qualified path (not ${exec_prefix}/lib) +eval libdir="$libdir" + +#------------------------------------------------------------------------ +# Standard compiler checks +#------------------------------------------------------------------------ + +# If the user did not set CFLAGS, set it now to keep +# the AC_PROG_CC macro from adding "-g -O2". +if test "${CFLAGS+set}" != "set" ; then + CFLAGS="" +fi + +AC_PROG_CC +AC_C_INLINE +AC_HEADER_STDC + +AC_CHECK_TOOL(AR, ar) +AC_CHECK_TOOL(RANLIB, ranlib) +AC_CHECK_TOOL(RC, windres) + +#-------------------------------------------------------------------- +# Checks to see if the make program sets the $MAKE variable. +#-------------------------------------------------------------------- + +AC_PROG_MAKE_SET + +#-------------------------------------------------------------------- +# Determines the correct binary file extension (.o, .obj, .exe etc.) +#-------------------------------------------------------------------- + +AC_OBJEXT +AC_EXEEXT + +#-------------------------------------------------------------------- +# Check whether --enable-threads or --disable-threads was given. +#-------------------------------------------------------------------- + +SC_ENABLE_THREADS + +#------------------------------------------------------------------------ +# Embedded configuration information, encoding to use for the values, TIP #59 +#------------------------------------------------------------------------ + +SC_TCL_CFG_ENCODING + +#-------------------------------------------------------------------- +# The statements below define a collection of symbols related to +# building libtcl as a shared library instead of a static library. +#-------------------------------------------------------------------- + +SC_ENABLE_SHARED + +#-------------------------------------------------------------------- +# The statements below define a collection of compile flags. This +# macro depends on the value of SHARED_BUILD, and should be called +# after SC_ENABLE_SHARED checks the configure switches. +#-------------------------------------------------------------------- + +SC_CONFIG_CFLAGS + +# Cross-compiling +case ${host_alias} in +*mingw32*) + TCL_EXE="tclsh" + ;; +*) + TCL_EXE="TCL_LIBRARY=\"\${LIBRARY_DIR}\"; export TCL_LIBRARY; ./\${TCLSH}" + ;; +esac + +#------------------------------------------------------------------------ +# Add stuff for zlib; note that this is mostly done in the makefile now +# as we just assume that the platform hasn't got a usable z.lib +#------------------------------------------------------------------------ + +AS_IF([test "${enable_shared+set}" = "set"], [ + enableval="$enable_shared" + tcl_ok=$enableval +], [ + tcl_ok=yes +]) +AS_IF([test "$tcl_ok" = "yes"], [ + AC_SUBST(ZLIB_DLL_FILE,[\${ZLIB_DLL_FILE}]) + AS_IF([test "$do64bit" = "yes"], [ + AS_IF([test "$GCC" == "yes"],[ + AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64/libz.dll.a]) + ], [ + AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64/zdll.lib]) + ]) + ], [ + AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win32/zdll.lib]) + ]) +], [ + AC_SUBST(ZLIB_OBJS,[\${ZLIB_OBJS}]) +]) +AC_DEFINE(HAVE_ZLIB, 1, [Is there an installed zlib?]) + +AC_CHECK_TYPE([intptr_t], [ + AC_DEFINE([HAVE_INTPTR_T], 1, [Do we have the intptr_t type?])], [ + AC_CACHE_CHECK([for pointer-size signed integer type], tcl_cv_intptr_t, [ + for tcl_cv_intptr_t in "int" "long" "long long" none; do + if test "$tcl_cv_intptr_t" != none; then + AC_COMPILE_IFELSE([AC_LANG_BOOL_COMPILE_TRY([AC_INCLUDES_DEFAULT], + [[sizeof (void *) <= sizeof ($tcl_cv_intptr_t)]])], + [tcl_ok=yes], [tcl_ok=no]) + test "$tcl_ok" = yes && break; fi + done]) + if test "$tcl_cv_intptr_t" != none; then + AC_DEFINE_UNQUOTED([intptr_t], [$tcl_cv_intptr_t], [Signed integer + type wide enough to hold a pointer.]) + fi +]) +AC_CHECK_TYPE([uintptr_t], [ + AC_DEFINE([HAVE_UINTPTR_T], 1, [Do we have the uintptr_t type?])], [ + AC_CACHE_CHECK([for pointer-size unsigned integer type], tcl_cv_uintptr_t, [ + for tcl_cv_uintptr_t in "unsigned int" "unsigned long" "unsigned long long" \ + none; do + if test "$tcl_cv_uintptr_t" != none; then + AC_COMPILE_IFELSE([AC_LANG_BOOL_COMPILE_TRY([AC_INCLUDES_DEFAULT], + [[sizeof (void *) <= sizeof ($tcl_cv_uintptr_t)]])], + [tcl_ok=yes], [tcl_ok=no]) + test "$tcl_ok" = yes && break; fi + done]) + if test "$tcl_cv_uintptr_t" != none; then + AC_DEFINE_UNQUOTED([uintptr_t], [$tcl_cv_uintptr_t], [Unsigned integer + type wide enough to hold a pointer.]) + fi +]) + +#-------------------------------------------------------------------- +# Perform additinal compiler tests. +#-------------------------------------------------------------------- + +# 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 + +# 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 +# after SC_CONFIG_CFLAGS macro is called. +#-------------------------------------------------------------------- + +SC_ENABLE_SYMBOLS + +TCL_DBGX=${DBGX} + +#-------------------------------------------------------------------- +# Embed the manifest if we can determine how +#-------------------------------------------------------------------- + +SC_EMBED_MANIFEST + +#------------------------------------------------------------------------ +# tclConfig.sh refers to this by a different name +#------------------------------------------------------------------------ + +TCL_SHARED_BUILD=${SHARED_BUILD} + +#-------------------------------------------------------------------- +# Perform final evaluations of variables with possible substitutions. +#-------------------------------------------------------------------- + +TCL_SHARED_LIB_SUFFIX="\${NODOT_VERSION}${DLLSUFFIX}" +TCL_UNSHARED_LIB_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}" +TCL_EXPORT_FILE_SUFFIX="\${NODOT_VERSION}${LIBSUFFIX}" + +eval "TCL_SRC_DIR=\"`cd $srcdir/..; $CYGPATH $(pwd)`\"" + +eval "TCL_DLL_FILE=tcl${VER}${DLLSUFFIX}" + +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}\"" +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}\"" + + +eval "DLLSUFFIX=${DLLSUFFIX}" +eval "LIBPREFIX=${LIBPREFIX}" +eval "LIBSUFFIX=${LIBSUFFIX}" +eval "EXESUFFIX=${EXESUFFIX}" + +CFG_TCL_SHARED_LIB_SUFFIX=${TCL_SHARED_LIB_SUFFIX} +CFG_TCL_UNSHARED_LIB_SUFFIX=${TCL_UNSHARED_LIB_SUFFIX} +CFG_TCL_EXPORT_FILE_SUFFIX=${TCL_EXPORT_FILE_SUFFIX} + +#-------------------------------------------------------------------- +# Adjust the defines for how the resources are built depending +# on symbols and static vs. shared. +#-------------------------------------------------------------------- + +if test ${SHARED_BUILD} = 0 ; then + if test "${DBGX}" = "g"; then + RC_DEFINES="${RC_DEFINE} STATIC_BUILD ${RC_DEFINE} DEBUG" + else + RC_DEFINES="${RC_DEFINE} STATIC_BUILD" + fi +else + if test "${DBGX}" = "g"; then + RC_DEFINES="${RC_DEFINE} DEBUG" + else + RC_DEFINES="" + fi +fi + +#-------------------------------------------------------------------- +# The statements below define the symbol TCL_PACKAGE_PATH, which +# gives a list of directories that may contain packages. The list +# consists of one directory for machine-dependent binaries and +# another for platform-independent scripts. +#-------------------------------------------------------------------- + +if test "$prefix/lib" != "$libdir"; then + TCL_PACKAGE_PATH="${libdir} ${prefix}/lib" +else + TCL_PACKAGE_PATH="${prefix}/lib" +fi + +# The tclsh.exe.manifest requires these +# TCL_WIN_VERSION is the 4 dotted pair Windows version format which needs +# the release level, and must account for interim release versioning +case "$TCL_PATCH_LEVEL" in + *a*) TCL_RELEASE_LEVEL=0 ;; + *b*) TCL_RELEASE_LEVEL=1 ;; + *) TCL_RELEASE_LEVEL=2 ;; +esac +TCL_WIN_VERSION="$TCL_VERSION.$TCL_RELEASE_LEVEL.`echo $TCL_PATCH_LEVEL | tr -d ab.`" +AC_SUBST(TCL_WIN_VERSION) +# X86|AMD64|IA64 for manifest +AC_SUBST(MACHINE) + +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) +AC_SUBST(TCL_STUB_LIB_FLAG) +AC_SUBST(TCL_STUB_LIB_SPEC) +AC_SUBST(TCL_STUB_LIB_PATH) +AC_SUBST(TCL_INCLUDE_SPEC) +AC_SUBST(TCL_BUILD_STUB_LIB_SPEC) +AC_SUBST(TCL_BUILD_STUB_LIB_PATH) +AC_SUBST(TCL_DLL_FILE) + +AC_SUBST(TCL_SRC_DIR) +AC_SUBST(TCL_BIN_DIR) +AC_SUBST(TCL_DBGX) +AC_SUBST(CFG_TCL_SHARED_LIB_SUFFIX) +AC_SUBST(CFG_TCL_UNSHARED_LIB_SUFFIX) +AC_SUBST(CFG_TCL_EXPORT_FILE_SUFFIX) + +# win/tcl.m4 doesn't set (CFLAGS) +AC_SUBST(CFLAGS_DEFAULT) +AC_SUBST(EXTRA_CFLAGS) +AC_SUBST(CYGPATH) +AC_SUBST(DEPARG) +AC_SUBST(CC_OBJNAME) +AC_SUBST(CC_EXENAME) + +# win/tcl.m4 doesn't set (LDFLAGS) +AC_SUBST(LDFLAGS_DEFAULT) +AC_SUBST(LDFLAGS_DEBUG) +AC_SUBST(LDFLAGS_OPTIMIZE) +AC_SUBST(LDFLAGS_CONSOLE) +AC_SUBST(LDFLAGS_WINDOW) +AC_SUBST(AR) +AC_SUBST(RANLIB) + +AC_SUBST(STLIB_LD) +AC_SUBST(SHLIB_LD) +AC_SUBST(SHLIB_LD_LIBS) +AC_SUBST(SHLIB_CFLAGS) +AC_SUBST(SHLIB_SUFFIX) +AC_SUBST(TCL_SHARED_BUILD) + +AC_SUBST(LIBS) +AC_SUBST(LIBS_GUI) +AC_SUBST(DLLSUFFIX) +AC_SUBST(LIBPREFIX) +AC_SUBST(LIBSUFFIX) +AC_SUBST(EXESUFFIX) +AC_SUBST(LIBRARIES) +AC_SUBST(MAKE_LIB) +AC_SUBST(MAKE_STUB_LIB) +AC_SUBST(POST_MAKE_LIB) +AC_SUBST(MAKE_DLL) +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) +AC_SUBST(TCL_EXP_FILE) +AC_SUBST(DL_LIBS) +AC_SUBST(TCL_LIB_VERSIONS_OK) +AC_SUBST(TCL_PACKAGE_PATH) + +# win only +AC_SUBST(TCL_DDE_VERSION) +AC_SUBST(TCL_DDE_MAJOR_VERSION) +AC_SUBST(TCL_DDE_MINOR_VERSION) +AC_SUBST(TCL_REG_VERSION) +AC_SUBST(TCL_REG_MAJOR_VERSION) +AC_SUBST(TCL_REG_MINOR_VERSION) + +AC_SUBST(RC) +AC_SUBST(RC_OUT) +AC_SUBST(RC_TYPE) +AC_SUBST(RC_INCLUDE) +AC_SUBST(RC_DEFINE) +AC_SUBST(RC_DEFINES) +AC_SUBST(RES) + +AC_OUTPUT(Makefile tclConfig.sh tcl.hpj tclsh.exe.manifest) + +dnl Local Variables: +dnl mode: autoconf; +dnl End: diff --git a/win/makefile.vc b/win/makefile.vc new file mode 100644 index 0000000..2bff871 --- /dev/null +++ b/win/makefile.vc @@ -0,0 +1,1257 @@ +#-------------------------------------------------------------
+# makefile.vc --
+#
+# Microsoft Visual C++ makefile for use with nmake.exe v1.62+ (VC++ 5.0+)
+#
+# 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-2000 Ajuba Solutions.
+# Copyright (c) 2001-2005 ActiveState Corporation.
+# Copyright (c) 2001-2004 David Gravereaux.
+# Copyright (c) 2003-2008 Pat Thoyts.
+#------------------------------------------------------------------------------
+
+# 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:
+#
+# 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.
+#
+# 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:
+# release -- Builds the core, the shell and the dlls. (default)
+# 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.
+# test -- Builds and runs the test suite.
+# tcltest -- Just builds the test shell.
+# install -- Installs the built binaries and libraries to $(INSTALLDIR)
+# as the root of the install tree.
+# tidy/clean/hose -- varying levels of cleaning.
+# genstubs -- Rebuilds the Stubs table and support files (dev only).
+# depend -- Generates an accurate set of source dependancies for this
+# makefile. Helpful to avoid problems when the sources are
+# refreshed and you rebuild, but can "overbuild" when common
+# headers like tclInt.h just get small changes.
+# htmlhelp -- Builds a Windows .chm help file for Tcl and Tk from the
+# troff manual pages found in $(ROOT)\doc. You need to
+# have installed the HTML Help Compiler package from Microsoft
+# to produce the .chm file.
+# winhelp -- (deprecated) Builds the windows .hlp file for Tcl from
+# the troff man files found in $(ROOT)\doc. This type of
+# help file is deprecated by Microsoft in favour of html
+# help files (.chm)
+#
+# 4) Macros usable on the commandline:
+# INSTALLDIR=<path>
+# Sets where to install Tcl from the built binaries.
+# C:\Progra~1\Tcl is assumed when not specified.
+#
+# OPTS=loimpact,msvcrt,nothreads,pdbs,profile,static,staticpkg,symbols,thrdalloc,tclalloc,unchecked,none
+# 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.
+# nothreads= Turns off full multithreading support.
+# pdbs = Build detached symbols for release builds.
+# profile = Adds profiling hooks. Map file is assumed.
+# static = Builds a static library of the core instead of a
+# dll. The static library will contain the dde and reg
+# extensions. External applications who want to use
+# this, need to link with the stub library as well as
+# the static Tcl library.The shell will be static (and
+# large), as well.
+# staticpkg = Affects the static option only to switch
+# tclshXX.exe to have the dde and reg extension linked
+# inside it.
+# symbols = Debug build. Links to the debug C runtime, disables
+# optimizations and creates pdb symbols files.
+# thrdalloc = Use the thread allocator (shared global free pool)
+# This is the default on threaded builds.
+# tclalloc = Use the old non-thread allocator
+# unchecked= Allows a symbols build to not use the debug
+# 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.
+#
+# MACHINE=(ARM|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.
+#
+# 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.
+# c:\tcl_src\win\>nmake -f makefile.vc release
+# c:\tcl_src\win\>nmake -f makefile.vc install INSTALLDIR=c:\progra~1\tcl
+#
+# 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
+#
+#------------------------------------------------------------------------------
+#==============================================================================
+###############################################################################
+
+
+# //==================================================================\\
+# >>[ -> 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. ]<<
+# \\==================================================================//
+
+
+###############################################################################
+#==============================================================================
+#------------------------------------------------------------------------------
+
+!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
+
+PROJECT = tcl
+!include "rules.vc"
+
+STUBPREFIX = $(PROJECT)stub
+DOTVERSION = $(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION)
+VERSION = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION)
+
+DDEDOTVERSION = 1.4
+DDEVERSION = $(DDEDOTVERSION:.=)
+
+REGDOTVERSION = 1.3
+REGVERSION = $(REGDOTVERSION:.=)
+
+BINROOT = $(MAKEDIR) # originally .
+ROOT = $(MAKEDIR)\.. # originally ..
+
+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)
+
+TCLREGLIBNAME = $(PROJECT)reg$(REGVERSION)$(SUFX:t=).$(EXT)
+TCLREGLIB = $(OUT_DIR)\$(TCLREGLIBNAME)
+
+TCLDDELIBNAME = $(PROJECT)dde$(DDEVERSION)$(SUFX:t=).$(EXT)
+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 = \
+ $(TMP_DIR)\tclTest.obj \
+ $(TMP_DIR)\tclTestObj.obj \
+ $(TMP_DIR)\tclTestProcBodyObj.obj \
+ $(TMP_DIR)\tclThreadTest.obj \
+ $(TMP_DIR)\tclWinTest.obj \
+!if !$(STATIC_BUILD)
+!if $(TCL_USE_STATIC_PACKAGES)
+ $(TMP_DIR)\tclWinReg.obj \
+ $(TMP_DIR)\tclWinDde.obj \
+!endif
+!endif
+ $(TMP_DIR)\testMain.obj
+
+COREOBJS = \
+ $(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 \
+ $(TMP_DIR)\tclCkalloc.obj \
+ $(TMP_DIR)\tclClock.obj \
+ $(TMP_DIR)\tclCmdAH.obj \
+ $(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 \
+ $(TMP_DIR)\tclFCmd.obj \
+ $(TMP_DIR)\tclFileName.obj \
+ $(TMP_DIR)\tclGet.obj \
+ $(TMP_DIR)\tclHash.obj \
+ $(TMP_DIR)\tclHistory.obj \
+ $(TMP_DIR)\tclIndexObj.obj \
+ $(TMP_DIR)\tclInterp.obj \
+ $(TMP_DIR)\tclIO.obj \
+ $(TMP_DIR)\tclIOCmd.obj \
+ $(TMP_DIR)\tclIOGT.obj \
+ $(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 \
+ $(TMP_DIR)\tclPipe.obj \
+ $(TMP_DIR)\tclPkg.obj \
+ $(TMP_DIR)\tclPkgConfig.obj \
+ $(TMP_DIR)\tclPosixStr.obj \
+ $(TMP_DIR)\tclPreserve.obj \
+ $(TMP_DIR)\tclProc.obj \
+ $(TMP_DIR)\tclRegexp.obj \
+ $(TMP_DIR)\tclResolve.obj \
+ $(TMP_DIR)\tclResult.obj \
+ $(TMP_DIR)\tclScan.obj \
+ $(TMP_DIR)\tclStringObj.obj \
+ $(TMP_DIR)\tclStrToD.obj \
+ $(TMP_DIR)\tclStubInit.obj \
+ $(TMP_DIR)\tclThread.obj \
+ $(TMP_DIR)\tclThreadAlloc.obj \
+ $(TMP_DIR)\tclThreadJoin.obj \
+ $(TMP_DIR)\tclThreadStorage.obj \
+ $(TMP_DIR)\tclTimer.obj \
+ $(TMP_DIR)\tclTomMathInterface.obj \
+ $(TMP_DIR)\tclTrace.obj \
+ $(TMP_DIR)\tclUtf.obj \
+ $(TMP_DIR)\tclUtil.obj \
+ $(TMP_DIR)\tclVar.obj \
+ $(TMP_DIR)\tclZlib.obj
+
+ZLIBOBJS = \
+ $(TMP_DIR)\adler32.obj \
+ $(TMP_DIR)\compress.obj \
+ $(TMP_DIR)\crc32.obj \
+ $(TMP_DIR)\deflate.obj \
+ $(TMP_DIR)\infback.obj \
+ $(TMP_DIR)\inffast.obj \
+ $(TMP_DIR)\inflate.obj \
+ $(TMP_DIR)\inftrees.obj \
+ $(TMP_DIR)\trees.obj \
+ $(TMP_DIR)\uncompr.obj \
+ $(TMP_DIR)\zutil.obj
+
+TOMMATHOBJS = \
+ $(TMP_DIR)\bncore.obj \
+ $(TMP_DIR)\bn_reverse.obj \
+ $(TMP_DIR)\bn_fast_s_mp_mul_digs.obj \
+ $(TMP_DIR)\bn_fast_s_mp_sqr.obj \
+ $(TMP_DIR)\bn_mp_add.obj \
+ $(TMP_DIR)\bn_mp_add_d.obj \
+ $(TMP_DIR)\bn_mp_and.obj \
+ $(TMP_DIR)\bn_mp_clamp.obj \
+ $(TMP_DIR)\bn_mp_clear.obj \
+ $(TMP_DIR)\bn_mp_clear_multi.obj \
+ $(TMP_DIR)\bn_mp_cmp.obj \
+ $(TMP_DIR)\bn_mp_cmp_d.obj \
+ $(TMP_DIR)\bn_mp_cmp_mag.obj \
+ $(TMP_DIR)\bn_mp_cnt_lsb.obj \
+ $(TMP_DIR)\bn_mp_copy.obj \
+ $(TMP_DIR)\bn_mp_count_bits.obj \
+ $(TMP_DIR)\bn_mp_div.obj \
+ $(TMP_DIR)\bn_mp_div_d.obj \
+ $(TMP_DIR)\bn_mp_div_2.obj \
+ $(TMP_DIR)\bn_mp_div_2d.obj \
+ $(TMP_DIR)\bn_mp_div_3.obj \
+ $(TMP_DIR)\bn_mp_exch.obj \
+ $(TMP_DIR)\bn_mp_expt_d.obj \
+ $(TMP_DIR)\bn_mp_expt_d_ex.obj \
+ $(TMP_DIR)\bn_mp_get_int.obj \
+ $(TMP_DIR)\bn_mp_get_long.obj \
+ $(TMP_DIR)\bn_mp_get_long_long.obj \
+ $(TMP_DIR)\bn_mp_grow.obj \
+ $(TMP_DIR)\bn_mp_init.obj \
+ $(TMP_DIR)\bn_mp_init_copy.obj \
+ $(TMP_DIR)\bn_mp_init_multi.obj \
+ $(TMP_DIR)\bn_mp_init_set.obj \
+ $(TMP_DIR)\bn_mp_init_set_int.obj \
+ $(TMP_DIR)\bn_mp_init_size.obj \
+ $(TMP_DIR)\bn_mp_karatsuba_mul.obj \
+ $(TMP_DIR)\bn_mp_karatsuba_sqr.obj \
+ $(TMP_DIR)\bn_mp_lshd.obj \
+ $(TMP_DIR)\bn_mp_mod.obj \
+ $(TMP_DIR)\bn_mp_mod_2d.obj \
+ $(TMP_DIR)\bn_mp_mul.obj \
+ $(TMP_DIR)\bn_mp_mul_2.obj \
+ $(TMP_DIR)\bn_mp_mul_2d.obj \
+ $(TMP_DIR)\bn_mp_mul_d.obj \
+ $(TMP_DIR)\bn_mp_neg.obj \
+ $(TMP_DIR)\bn_mp_or.obj \
+ $(TMP_DIR)\bn_mp_radix_size.obj \
+ $(TMP_DIR)\bn_mp_radix_smap.obj \
+ $(TMP_DIR)\bn_mp_read_radix.obj \
+ $(TMP_DIR)\bn_mp_rshd.obj \
+ $(TMP_DIR)\bn_mp_set.obj \
+ $(TMP_DIR)\bn_mp_set_int.obj \
+ $(TMP_DIR)\bn_mp_set_long.obj \
+ $(TMP_DIR)\bn_mp_set_long_long.obj \
+ $(TMP_DIR)\bn_mp_shrink.obj \
+ $(TMP_DIR)\bn_mp_sqr.obj \
+ $(TMP_DIR)\bn_mp_sqrt.obj \
+ $(TMP_DIR)\bn_mp_sub.obj \
+ $(TMP_DIR)\bn_mp_sub_d.obj \
+ $(TMP_DIR)\bn_mp_to_unsigned_bin.obj \
+ $(TMP_DIR)\bn_mp_to_unsigned_bin_n.obj \
+ $(TMP_DIR)\bn_mp_toom_mul.obj \
+ $(TMP_DIR)\bn_mp_toom_sqr.obj \
+ $(TMP_DIR)\bn_mp_toradix_n.obj \
+ $(TMP_DIR)\bn_mp_unsigned_bin_size.obj \
+ $(TMP_DIR)\bn_mp_xor.obj \
+ $(TMP_DIR)\bn_mp_zero.obj \
+ $(TMP_DIR)\bn_s_mp_add.obj \
+ $(TMP_DIR)\bn_s_mp_mul_digs.obj \
+ $(TMP_DIR)\bn_s_mp_sqr.obj \
+ $(TMP_DIR)\bn_s_mp_sub.obj
+
+PLATFORMOBJS = \
+ $(TMP_DIR)\tclWin32Dll.obj \
+ $(TMP_DIR)\tclWinChan.obj \
+ $(TMP_DIR)\tclWinConsole.obj \
+ $(TMP_DIR)\tclWinError.obj \
+ $(TMP_DIR)\tclWinFCmd.obj \
+ $(TMP_DIR)\tclWinFile.obj \
+ $(TMP_DIR)\tclWinInit.obj \
+ $(TMP_DIR)\tclWinLoad.obj \
+ $(TMP_DIR)\tclWinNotify.obj \
+ $(TMP_DIR)\tclWinPipe.obj \
+ $(TMP_DIR)\tclWinSerial.obj \
+ $(TMP_DIR)\tclWinSock.obj \
+ $(TMP_DIR)\tclWinThrd.obj \
+ $(TMP_DIR)\tclWinTime.obj \
+!if $(STATIC_BUILD)
+ $(TMP_DIR)\tclWinReg.obj \
+ $(TMP_DIR)\tclWinDde.obj \
+!else
+ $(TMP_DIR)\tcl.res
+!endif
+
+TCLOBJS = $(COREOBJS) $(ZLIBOBJS) $(TOMMATHOBJS) $(PLATFORMOBJS)
+
+TCLSTUBOBJS = \
+ $(TMP_DIR)\tclStubLib.obj \
+ $(TMP_DIR)\tclTomMathStubLib.obj \
+ $(TMP_DIR)\tclOOStubLib.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
+PKGSDIR = $(ROOT)\pkgs
+
+#---------------------------------------------------------------------
+# 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
+
+### Common compiler options that are architecture specific
+!if "$(MACHINE)" == "ARM"
+carch = -D_ARM_WINAPI_PARTITION_DESKTOP_SDK_AVAILABLE
+!else
+carch =
+!endif
+
+### Declarations common to all compiler options
+cwarn = $(WARNINGS) -D _CRT_SECURE_NO_DEPRECATE -D _CRT_NONSTDC_NO_DEPRECATE
+cflags = -nologo -c $(COMPILERFLAGS) $(carch) $(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 = -DMP_PREC=4 -Dinline=__inline -DHAVE_ZLIB=1
+BASE_CFLAGS = $(cflags) $(cdebug) $(crt) $(TCL_INCLUDES) $(TCL_DEFINES)
+CON_CFLAGS = $(cflags) $(cdebug) $(crt) -DCONSOLE
+TCL_CFLAGS = $(BASE_CFLAGS) $(OPTDEFINES)
+STUB_CFLAGS = $(cflags) $(cdebug) $(OPTDEFINES)
+
+
+#---------------------------------------------------------------------
+# Link flags
+#---------------------------------------------------------------------
+
+!if $(DEBUG)
+ldebug = -debug -debugtype:cv
+!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
+!endif
+
+!if $(MSVCRT) && !($(DEBUG) && !$(UNCHECKED)) && $(VCVERSION) >= 1900
+lflags = $(lflags) -nodefaultlib:libucrt.lib
+!endif
+
+!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
+
+!if $(LOIMPACT)
+lflags = $(lflags) -ws:aggressive
+!endif
+
+dlllflags = $(lflags) -dll
+conlflags = $(lflags) -subsystem:console
+guilflags = $(lflags) -subsystem:windows
+
+baselibs = netapi32.lib kernel32.lib user32.lib advapi32.lib userenv.lib ws2_32.lib
+# 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
+
+#---------------------------------------------------------------------
+# TclTest flags
+#---------------------------------------------------------------------
+
+!if "$(TESTPAT)" != ""
+TESTFLAGS = $(TESTFLAGS) -file $(TESTPAT)
+!endif
+
+
+#---------------------------------------------------------------------
+# Project specific targets
+#---------------------------------------------------------------------
+
+release: setup $(TCLSH) $(TCLSTUBLIB) dlls pkgs
+core: setup $(TCLLIB) $(TCLSTUBLIB)
+shell: setup $(TCLSH)
+dlls: setup $(TCLREGLIB) $(TCLDDELIB)
+all: setup $(TCLSH) $(TCLSTUBLIB) dlls $(CAT32) pkgs
+tcltest: setup $(TCLTEST) dlls $(CAT32)
+install: install-binaries install-libraries install-docs install-pkgs
+
+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.0 [list load "$(TCLDDELIB:\=/)" dde]
+ package ifneeded registry 1.3.2 [list load "$(TCLREGLIB:\=/)" registry]
+<<
+!else
+ @echo Please wait while the tests are collected...
+ $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << > tests.log
+ package ifneeded dde 1.4.0 "$(TCLDDELIB:\=/)" dde]
+ package ifneeded registry 1.3.2 "$(TCLREGLIB:\=/)" registry]
+<<
+ type tests.log | more
+!endif
+
+runtest: setup $(TCLTEST) dlls $(CAT32)
+ set TCL_LIBRARY=$(ROOT:\=/)/library
+ $(DEBUGGER) $(TCLTEST) $(SCRIPT)
+
+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
+
+$(TCLLIB): $(TCLOBJS)
+!if $(STATIC_BUILD)
+ $(lib32) -nologo $(LINKERFLAGS) -out:$@ @<<
+$**
+<<
+!else
+ $(link32) $(dlllflags) -base:@$(WINDIR)\coffbase.txt,tcl -out:$@ \
+ $(baselibs) @<<
+$**
+<<
+ $(_VC_MANIFEST_EMBED_DLL)
+!endif
+
+$(TCLSTUBLIB): $(TCLSTUBOBJS)
+ $(lib32) -nologo $(LINKERFLAGS) -nodefaultlib -out:$@ $(TCLSTUBOBJS)
+
+$(TCLSH): $(TCLSHOBJS) $(TCLSTUBLIB) $(TCLIMPLIB)
+ $(link32) $(conlflags) -stack:2300000 -out:$@ $(baselibs) $**
+ $(_VC_MANIFEST_EMBED_EXE)
+
+$(TCLTEST): $(TCLTESTOBJS) $(TCLSTUBLIB) $(TCLIMPLIB)
+ $(link32) $(conlflags) -stack:2300000 -out:$@ $(baselibs) $**
+ $(_VC_MANIFEST_EMBED_EXE)
+
+!if $(STATIC_BUILD)
+$(TCLDDELIB): $(TMP_DIR)\tclWinDde.obj
+ $(lib32) -nologo $(LINKERFLAGS) -out:$@ $**
+!else
+$(TCLDDELIB): $(TMP_DIR)\tclWinDde.obj $(TCLSTUBLIB)
+ $(link32) $(dlllflags) -base:@$(WINDIR)\coffbase.txt,tcldde -out:$@ \
+ $** $(baselibs)
+ $(_VC_MANIFEST_EMBED_DLL)
+!endif
+
+!if $(STATIC_BUILD)
+$(TCLREGLIB): $(TMP_DIR)\tclWinReg.obj
+ $(lib32) -nologo $(LINKERFLAGS) -out:$@ $**
+!else
+$(TCLREGLIB): $(TMP_DIR)\tclWinReg.obj $(TCLSTUBLIB)
+ $(link32) $(dlllflags) -base:@$(WINDIR)\coffbase.txt,tclreg -out:$@ \
+ $** $(baselibs)
+ $(_VC_MANIFEST_EMBED_DLL)
+!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)
+ $(_VC_MANIFEST_EMBED_EXE)
+
+#---------------------------------------------------------------------
+# Regenerate the stubs files. [Development use only]
+#---------------------------------------------------------------------
+
+genstubs:
+!if !exist($(TCLSH))
+ @echo Build tclsh first!
+!else
+ $(TCLSH) $(TOOLSDIR:\=/)/genStubs.tcl $(GENERICDIR:\=/) \
+ $(GENERICDIR:\=/)/tcl.decls $(GENERICDIR:\=/)/tclInt.decls \
+ $(GENERICDIR:\=/)/tclTomMath.decls
+ $(TCLSH) $(TOOLSDIR:\=/)/genStubs.tcl $(GENERICDIR:\=/) \
+ $(GENERICDIR:\=/)/tclOO.decls
+!endif
+
+
+#----------------------------------------------------------------------
+# The following target generates the file generic/tclTomMath.h.
+# It needs to be run (and the results checked) after updating
+# to a new release of libtommath.
+#----------------------------------------------------------------------
+
+gentommath_h:
+!if !exist($(TCLSH))
+ @echo Build tclsh first!
+!else
+ $(TCLSH) "$(TOOLSDIR:\=/)/fix_tommath_h.tcl" \
+ "$(TOMMATHDIR:\=/)/tommath.h" \
+ > "$(GENERICDIR)\tclTomMath.h"
+!endif
+
+#---------------------------------------------------------------------
+# 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""
+!endif
+HTMLDIR=$(OUT_DIR)\html
+HTMLBASE=TclTk$(VERSION)
+HHPFILE=$(HTMLDIR)\$(HTMLBASE).hhp
+CHMFILE=$(HTMLDIR)\$(HTMLBASE).chm
+
+htmlhelp: chmsetup $(CHMFILE)
+
+$(CHMFILE): $(DOCDIR)\*
+ @$(TCLSH) $(TOOLSDIR)\tcltk-man2html.tcl "--htmldir=$(HTMLDIR)"
+ @echo Compiling HTML help project
+ -$(HHC) <<$(HHPFILE) >NUL
+[OPTIONS]
+Compatibility=1.1 or later
+Compiled file=$(HTMLBASE).chm
+Default topic=contents.htm
+Display compile progress=no
+Error log file=$(HTMLBASE).log
+Full-text search=Yes
+Language=0x409 English (United States)
+Title=Tcl/Tk $(DOT_VERSION) Help
+[FILES]
+contents.htm
+docs.css
+Keywords\*.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
+
+#---------------------------------------------------------------------
+# Build tclConfig.sh for the TEA build system.
+#---------------------------------------------------------------------
+
+tclConfig: $(OUT_DIR)\tclConfig.sh
+
+$(OUT_DIR)\tclConfig.sh: $(WINDIR)\tclConfig.sh.in
+ @echo Creating tclConfig.sh
+ @nmakehlp -s << $** >$@
+@TCL_DLL_FILE@ $(TCLLIBNAME)
+@TCL_VERSION@ $(DOTVERSION)
+@TCL_MAJOR_VERSION@ $(TCL_MAJOR_VERSION)
+@TCL_MINOR_VERSION@ $(TCL_MINOR_VERSION)
+@TCL_PATCH_LEVEL@ $(TCL_PATCH_LEVEL)
+@CC@ $(CC)
+@DEFS@ $(TCL_CFLAGS)
+@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
+@LDFLAGS_OPTIMIZE@ -nologo -machine:$(MACHINE) -release -opt:ref -opt:icf,3
+@TCL_DBGX@ $(SUFX)
+@TCL_LIB_FILE@ $(PROJECT)$(VERSION)$(SUFX).lib
+@TCL_NEEDS_EXP_FILE@
+@LIBS@ $(baselibs)
+@prefix@ $(_INSTALLDIR)
+@exec_prefix@ $(BIN_INSTALL_DIR)
+@SHLIB_CFLAGS@
+@STLIB_CFLAGS@
+@CFLAGS_WARNING@ -W3
+@EXTRA_CFLAGS@ -YX
+@SHLIB_LD@ $(link32) $(dlllflags)
+@STLIB_LD@ $(lib32) -nologo
+@SHLIB_LD_LIBS@ $(baselibs)
+@SHLIB_SUFFIX@ .dll
+@DL_LIBS@
+@LDFLAGS@
+@TCL_CC_SEARCH_FLAGS@
+@TCL_LD_SEARCH_FLAGS@
+@LIBOBJS@
+@RANLIB@
+@TCL_LIB_FLAG@
+@TCL_BUILD_LIB_SPEC@
+@TCL_LIB_SPEC@ $(LIB_INSTALL_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib
+@TCL_INCLUDE_SPEC@ -I$(INCLUDE_INSTALL_DIR)
+@TCL_LIB_VERSIONS_OK@
+@TCL_SRC_DIR@ $(ROOT)
+@TCL_PACKAGE_PATH@
+@TCL_STUB_LIB_FILE@ $(TCLSTUBLIBNAME)
+@TCL_STUB_LIB_FLAG@ $(TCLSTUBLIBNAME)
+@TCL_STUB_LIB_SPEC@ -L$(LIB_INSTALL_DIR) $(TCLSTUBLIBNAME)
+@TCL_THREADS@ $(TCL_THREADS)
+@TCL_BUILD_STUB_LIB_SPEC@ -L$(OUT_DIR) $(TCLSTUBLIBNAME)
+@TCL_BUILD_STUB_LIB_PATH@ $(TCLSTUBLIB)
+@TCL_STUB_LIB_PATH@ $(LIB_INSTALL_DIR)\$(TCLSTUBLIBNAME)
+@CFG_TCL_EXPORT_FILE_SUFFIX@ $(VERSION)$(SUFX).lib
+@CFG_TCL_SHARED_LIB_SUFFIX@ $(VERSION)$(SUFX).dll
+@CFG_TCL_UNSHARED_LIB_SUFFIX@ $(VERSION)$(SUFX).lib
+!if $(STATIC_BUILD)
+@TCL_SHARED_BUILD@ 0
+!else
+@TCL_SHARED_BUILD@ 1
+!endif
+<<
+
+
+#---------------------------------------------------------------------
+# The following target generates the file generic/tclDate.c
+# from the yacc grammar found in generic/tclGetDate.y. This is
+# only run by hand as yacc is not available in all environments.
+# The name of the .c file is different than the name of the .y file
+# so that make doesn't try to automatically regenerate the .c file.
+#---------------------------------------------------------------------
+
+gendate:
+ bison --output-file=$(GENERICDIR)/tclDate.c \
+ --name-prefix=TclDate \
+ $(GENERICDIR)/tclGetDate.y
+
+#---------------------------------------------------------------------
+# Special case object file targets
+#---------------------------------------------------------------------
+
+$(TMP_DIR)\testMain.obj: $(WINDIR)\tclAppInit.c
+ $(cc32) $(TCL_CFLAGS) -DTCL_TEST \
+ -DTCL_USE_STATIC_PACKAGES=$(TCL_USE_STATIC_PACKAGES) \
+ -Fo$@ $?
+
+$(TMP_DIR)\tclMain2.obj: $(GENERICDIR)\tclMain.c
+ $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -DTCL_ASCII_MAIN \
+ -Fo$@ $?
+
+$(TMP_DIR)\tclTest.obj: $(GENERICDIR)\tclTest.c
+ $(cc32) $(TCL_CFLAGS) -Fo$@ $?
+
+$(TMP_DIR)\tclTestObj.obj: $(GENERICDIR)\tclTestObj.c
+ $(cc32) $(TCL_CFLAGS) -Fo$@ $?
+
+$(TMP_DIR)\tclWinTest.obj: $(WINDIR)\tclWinTest.c
+ $(cc32) $(TCL_CFLAGS) -Fo$@ $?
+
+$(TMP_DIR)\tclZlib.obj: $(GENERICDIR)\tclZlib.c
+ $(cc32) $(TCL_CFLAGS) -I$(COMPATDIR)\zlib -DBUILD_tcl -Fo$@ $?
+
+$(TMP_DIR)\tclPkgConfig.obj: $(GENERICDIR)\tclPkgConfig.c
+ $(cc32) -DBUILD_tcl $(TCL_CFLAGS) \
+ -DCFG_INSTALL_LIBDIR="\"$(LIB_INSTALL_DIR:\=\\)\"" \
+ -DCFG_INSTALL_BINDIR="\"$(BIN_INSTALL_DIR:\=\\)\"" \
+ -DCFG_INSTALL_SCRDIR="\"$(SCRIPT_INSTALL_DIR:\=\\)\"" \
+ -DCFG_INSTALL_INCDIR="\"$(INCLUDE_INSTALL_DIR:\=\\)\"" \
+ -DCFG_INSTALL_DOCDIR="\"$(DOC_INSTALL_DIR:\=\\)\"" \
+ -DCFG_RUNTIME_LIBDIR="\"$(LIB_INSTALL_DIR:\=\\)\"" \
+ -DCFG_RUNTIME_BINDIR="\"$(BIN_INSTALL_DIR:\=\\)\"" \
+ -DCFG_RUNTIME_SCRDIR="\"$(SCRIPT_INSTALL_DIR:\=\\)\"" \
+ -DCFG_RUNTIME_INCDIR="\"$(INCLUDE_INSTALL_DIR:\=\\)\"" \
+ -DCFG_RUNTIME_DOCDIR="\"$(DOC_INSTALL_DIR:\=\\)\"" \
+ -Fo$@ $?
+
+$(TMP_DIR)\tclAppInit.obj: $(WINDIR)\tclAppInit.c
+ $(cc32) $(TCL_CFLAGS) \
+ -DTCL_USE_STATIC_PACKAGES=$(TCL_USE_STATIC_PACKAGES) \
+ -Fo$@ $?
+
+### The following objects should be built using the stub interfaces
+### *ALL* extensions need to built with -DTCL_THREADS=1
+
+$(TMP_DIR)\tclWinReg.obj: $(WINDIR)\tclWinReg.c
+!if $(STATIC_BUILD)
+ $(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DSTATIC_BUILD -Fo$@ $?
+!else
+ $(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DUSE_TCL_STUBS -Fo$@ $?
+!endif
+
+
+$(TMP_DIR)\tclWinDde.obj: $(WINDIR)\tclWinDde.c
+!if $(STATIC_BUILD)
+ $(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DSTATIC_BUILD -Fo$@ $?
+!else
+ $(cc32) $(TCL_CFLAGS) -DTCL_THREADS=1 -DUSE_TCL_STUBS -Fo$@ $?
+!endif
+
+
+### The following objects are part of the stub library and should not
+### be built as DLL objects. -Zl is used to avoid a dependency on any
+### specific C run-time.
+
+$(TMP_DIR)\tclStubLib.obj: $(GENERICDIR)\tclStubLib.c
+ $(cc32) $(STUB_CFLAGS) -Zl -DSTATIC_BUILD $(TCL_INCLUDES) -Fo$@ $?
+
+$(TMP_DIR)\tclTomMathStubLib.obj: $(GENERICDIR)\tclTomMathStubLib.c
+ $(cc32) $(STUB_CFLAGS) -Zl -DSTATIC_BUILD $(TCL_INCLUDES) -Fo$@ $?
+
+$(TMP_DIR)\tclOOStubLib.obj: $(GENERICDIR)\tclOOStubLib.c
+ $(cc32) $(STUB_CFLAGS) -Zl -DSTATIC_BUILD $(TCL_INCLUDES) -Fo$@ $?
+
+$(TMP_DIR)\tclsh.exe.manifest: $(WINDIR)\tclsh.exe.manifest.in
+ @nmakehlp -s << $** >$@
+@MACHINE@ $(MACHINE:IX86=X86)
+@TCL_WIN_VERSION@ $(DOTVERSION).0.0
+<<
+
+#---------------------------------------------------------------------
+# Generate the source dependencies. Having dependency rules will
+# improve incremental build accuracy without having to resort to a
+# full rebuild just because some non-global header file like
+# tclCompile.h was changed. These rules aren't needed when building
+# from scratch.
+#---------------------------------------------------------------------
+
+depend:
+!if !exist($(TCLSH))
+ @echo Build tclsh first!
+!else
+ $(TCLSH) $(TOOLSDIR:\=/)/mkdepend.tcl -vc32 -out:"$(OUT_DIR)\depend.mk" \
+ -passthru:"-DBUILD_tcl $(TCL_INCLUDES)" $(GENERICDIR),$$(GENERICDIR) \
+ $(COMPATDIR),$$(COMPATDIR) $(TOMMATHDIR),$$(TOMMATHDIR) $(WINDIR),$$(WINDIR) @<<
+$(TCLOBJS)
+<<
+!endif
+
+#---------------------------------------------------------------------
+# Dependency rules
+#---------------------------------------------------------------------
+
+!if exist("$(OUT_DIR)\depend.mk")
+!include "$(OUT_DIR)\depend.mk"
+!message *** Dependency rules in use.
+!else
+!message *** Dependency rules are not being used.
+!endif
+
+### add a spacer in the output
+!message
+
+
+#---------------------------------------------------------------------
+# Implicit rules. A limitation exists with nmake that requires that
+# source directory can not contain spaces in the path. This an
+# absolute.
+#---------------------------------------------------------------------
+
+{$(WINDIR)}.c{$(TMP_DIR)}.obj::
+ $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<<
+$<
+<<
+
+{$(TOMMATHDIR)}.c{$(TMP_DIR)}.obj::
+ $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<<
+$<
+<<
+
+{$(GENERICDIR)}.c{$(TMP_DIR)}.obj::
+ $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<<
+$<
+<<
+
+{$(COMPATDIR)}.c{$(TMP_DIR)}.obj::
+ $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<<
+$<
+<<
+
+{$(COMPATDIR)\zlib}.c{$(TMP_DIR)}.obj::
+ $(cc32) $(TCL_CFLAGS) -DBUILD_tcl -Fo$(TMP_DIR)\ @<<
+$<
+<<
+
+{$(WINDIR)}.rc{$(TMP_DIR)}.res:
+ $(rc32) -fo $@ -r -i "$(GENERICDIR)" -i "$(TMP_DIR)" \
+ -d DEBUG=$(DEBUG) -d UNCHECKED=$(UNCHECKED) \
+ -d TCL_THREADS=$(TCL_THREADS) \
+ -d STATIC_BUILD=$(STATIC_BUILD) \
+ $<
+
+$(TMP_DIR)\tclsh.res: $(TMP_DIR)\tclsh.exe.manifest
+
+.SUFFIXES:
+.SUFFIXES:.c .rc
+
+
+#---------------------------------------------------------------------
+# Installation.
+#---------------------------------------------------------------------
+
+install-binaries:
+ @echo Installing to '$(_INSTALLDIR)'
+ @echo Installing $(TCLLIBNAME)
+!if "$(TCLLIB)" != "$(TCLIMPLIB)"
+ @$(CPY) "$(TCLLIB)" "$(BIN_INSTALL_DIR)\"
+!endif
+ @$(CPY) "$(TCLIMPLIB)" "$(LIB_INSTALL_DIR)\"
+!if exist($(TCLSH))
+ @echo Installing $(TCLSHNAME)
+ @$(CPY) "$(TCLSH)" "$(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)" \
+ $(MKDIR) "$(SCRIPT_INSTALL_DIR)"
+ @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl8$(NULL)" \
+ $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl8"
+ @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4$(NULL)" \
+ $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4"
+ @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4\platform$(NULL)" \
+ $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4\platform"
+ @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.5$(NULL)" \
+ $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.5"
+ @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.6$(NULL)" \
+ $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.6"
+ @echo Installing header files
+ @$(CPY) "$(GENERICDIR)\tcl.h" "$(INCLUDE_INSTALL_DIR)\"
+ @$(CPY) "$(GENERICDIR)\tclDecls.h" "$(INCLUDE_INSTALL_DIR)\"
+ @$(CPY) "$(GENERICDIR)\tclOO.h" "$(INCLUDE_INSTALL_DIR)\"
+ @$(CPY) "$(GENERICDIR)\tclOODecls.h" "$(INCLUDE_INSTALL_DIR)\"
+ @$(CPY) "$(GENERICDIR)\tclPlatDecls.h" "$(INCLUDE_INSTALL_DIR)\"
+ @$(CPY) "$(GENERICDIR)\tclTomMath.h" "$(INCLUDE_INSTALL_DIR)\"
+ @$(CPY) "$(GENERICDIR)\tclTomMathDecls.h" "$(INCLUDE_INSTALL_DIR)\"
+ @$(CPY) "$(TOMMATHDIR)\tommath_class.h" "$(INCLUDE_INSTALL_DIR)\"
+ @$(CPY) "$(TOMMATHDIR)\tommath_superclass.h" "$(INCLUDE_INSTALL_DIR)\"
+ @echo Installing library files to $(SCRIPT_INSTALL_DIR)
+ @$(CPY) "$(ROOT)\library\history.tcl" "$(SCRIPT_INSTALL_DIR)\"
+ @$(CPY) "$(ROOT)\library\init.tcl" "$(SCRIPT_INSTALL_DIR)\"
+ @$(CPY) "$(ROOT)\library\clock.tcl" "$(SCRIPT_INSTALL_DIR)\"
+ @$(CPY) "$(ROOT)\library\tm.tcl" "$(SCRIPT_INSTALL_DIR)\"
+ @$(CPY) "$(ROOT)\library\parray.tcl" "$(SCRIPT_INSTALL_DIR)\"
+ @$(CPY) "$(ROOT)\library\safe.tcl" "$(SCRIPT_INSTALL_DIR)\"
+ @$(CPY) "$(ROOT)\library\tclIndex" "$(SCRIPT_INSTALL_DIR)\"
+ @$(CPY) "$(ROOT)\library\package.tcl" "$(SCRIPT_INSTALL_DIR)\"
+ @$(CPY) "$(ROOT)\library\word.tcl" "$(SCRIPT_INSTALL_DIR)\"
+ @$(CPY) "$(ROOT)\library\auto.tcl" "$(SCRIPT_INSTALL_DIR)\"
+ @$(CPY) "$(OUT_DIR)\tclConfig.sh" "$(LIB_INSTALL_DIR)\"
+ @$(CPY) "$(WINDIR)\tclooConfig.sh" "$(LIB_INSTALL_DIR)\"
+ @echo Installing library http1.0 directory
+ @$(CPY) "$(ROOT)\library\http1.0\*.tcl" \
+ "$(SCRIPT_INSTALL_DIR)\http1.0\"
+ @echo Installing library opt0.4 directory
+ @$(CPY) "$(ROOT)\library\opt\*.tcl" \
+ "$(SCRIPT_INSTALL_DIR)\opt0.4\"
+ @echo Installing package http $(PKG_HTTP_VER) as a Tcl Module
+ @$(COPY) "$(ROOT)\library\http\http.tcl" \
+ "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.6\http-$(PKG_HTTP_VER).tm"
+ @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"
+ @echo Installing package tcltest $(PKG_TCLTEST_VER) as a Tcl Module
+ @$(COPY) "$(ROOT)\library\tcltest\tcltest.tcl" \
+ "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.5\tcltest-$(PKG_TCLTEST_VER).tm"
+ @echo Installing package platform $(PKG_PLATFORM_VER) as a Tcl Module
+ @$(COPY) "$(ROOT)\library\platform\platform.tcl" \
+ "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4\platform-$(PKG_PLATFORM_VER).tm"
+ @echo Installing package platform::shell $(PKG_SHELL_VER) as a Tcl Module
+ @$(COPY) "$(ROOT)\library\platform\shell.tcl" \
+ "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.4\platform\shell-$(PKG_SHELL_VER).tm"
+ @echo Installing $(TCLDDELIBNAME)
+!if $(STATIC_BUILD)
+!if !$(TCL_USE_STATIC_PACKAGES)
+ @$(CPY) "$(TCLDDELIB)" "$(LIB_INSTALL_DIR)\"
+!endif
+!else
+ @$(CPY) "$(TCLDDELIB)" "$(LIB_INSTALL_DIR)\dde$(DDEDOTVERSION)\"
+ @$(CPY) "$(ROOT)\library\dde\pkgIndex.tcl" \
+ "$(LIB_INSTALL_DIR)\dde$(DDEDOTVERSION)\"
+!endif
+ @echo Installing $(TCLREGLIBNAME)
+!if $(STATIC_BUILD)
+!if !$(TCL_USE_STATIC_PACKAGES)
+ @$(CPY) "$(TCLREGLIB)" "$(LIB_INSTALL_DIR)\"
+!endif
+!else
+ @$(CPY) "$(TCLREGLIB)" "$(LIB_INSTALL_DIR)\reg$(REGDOTVERSION)\"
+ @$(CPY) "$(ROOT)\library\reg\pkgIndex.tcl" \
+ "$(LIB_INSTALL_DIR)\reg$(REGDOTVERSION)\"
+!endif
+ @echo Installing encodings
+ @$(CPY) "$(ROOT)\library\encoding\*.enc" \
+ "$(SCRIPT_INSTALL_DIR)\encoding\"
+
+#" emacs fix
+
+install-tzdata:
+ @echo Installing time zone data
+ @set TCL_LIBRARY=$(ROOT:\=/)/library
+ @$(TCLSH_NATIVE) "$(ROOT:\=/)/tools/installData.tcl" \
+ "$(ROOT:\=/)/library/tzdata" "$(SCRIPT_INSTALL_DIR)/tzdata"
+
+install-msgs:
+ @echo Installing message catalogs
+ @set TCL_LIBRARY=$(ROOT:\=/)/library
+ @$(TCLSH_NATIVE) "$(ROOT:\=/)/tools/installData.tcl" \
+ "$(ROOT:\=/)/library/msgs" "$(SCRIPT_INSTALL_DIR)/msgs"
+
+#---------------------------------------------------------------------
+# Clean up
+#---------------------------------------------------------------------
+
+tidy:
+!if "$(TCLLIB)" != "$(TCLIMPLIB)"
+ @echo Removing $(TCLLIB) ...
+ @if exist $(TCLLIB) del $(TCLLIB)
+!endif
+ @echo Removing $(TCLIMPLIB) ...
+ @if exist $(TCLIMPLIB) del $(TCLIMPLIB)
+ @echo Removing $(TCLSH) ...
+ @if exist $(TCLSH) del $(TCLSH)
+ @echo Removing $(TCLTEST) ...
+ @if exist $(TCLTEST) del $(TCLTEST)
+ @echo Removing $(TCLDDELIB) ...
+ @if exist $(TCLDDELIB) del $(TCLDDELIB)
+ @echo Removing $(TCLREGLIB) ...
+ @if exist $(TCLREGLIB) del $(TCLREGLIB)
+
+clean: clean-pkgs
+ @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)\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 ...
+ @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
+
+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 new file mode 100644 index 0000000..22b7b06 --- /dev/null +++ b/win/nmakehlp.c @@ -0,0 +1,705 @@ +/* + * ---------------------------------------------------------------------------- + * nmakehlp.c -- + * + * This is used to fix limitations within nmake and the environment. + * + * Copyright (c) 2002 by David Gravereaux. + * Copyright (c) 2006 by Pat Thoyts + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + * ---------------------------------------------------------------------------- + */ + +#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> + +/* + * This library is required for x64 builds with _some_ versions of MSVC + */ +#if defined(_M_IA64) || defined(_M_AMD64) +#if _MSC_VER >= 1400 && _MSC_VER < 1500 +#pragma comment(lib, "bufferoverflowU") +#endif +#endif + +/* ISO hack for dumb VC++ */ +#ifdef _MSC_VER +#define snprintf _snprintf +#endif + + + +/* protos */ + +static int CheckForCompilerFeature(const char *option); +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 const char *GetVersionFromFile(const char *filename, const char *match, int numdots); +static DWORD WINAPI ReadFromPipe(LPVOID args); + +/* globals */ + +#define CHUNK 25 +#define STATICBUFFERSIZE 1000 +typedef struct { + HANDLE pipe; + char buffer[STATICBUFFERSIZE]; +} pipeinfo; + +pipeinfo Out = {INVALID_HANDLE_VALUE, '\0'}; +pipeinfo Err = {INVALID_HANDLE_VALUE, '\0'}; + +/* + * exitcodes: 0 == no, 1 == yes, 2 == error + */ + +int +main( + int argc, + char *argv[]) +{ + char msg[300]; + DWORD dwWritten; + int chars; + + /* + * Make sure children (cl.exe and link.exe) are kept quiet. + */ + + SetErrorMode(SEM_FAILCRITICALERRORS | SEM_NOOPENFILEERRORBOX); + + /* + * Make sure the compiler and linker aren't effected by the outside world. + */ + + SetEnvironmentVariable("CL", ""); + SetEnvironmentVariable("LINK", ""); + + if (argc > 1 && *argv[1] == '-') { + switch (*(argv[1]+1)) { + case 'c': + if (argc != 3) { + chars = snprintf(msg, sizeof(msg) - 1, + "usage: %s -c <compiler option>\n" + "Tests for whether cl.exe supports an option\n" + "exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]); + WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, + &dwWritten, NULL); + return 2; + } + return CheckForCompilerFeature(argv[2]); + case 'l': + if (argc < 3) { + chars = snprintf(msg, sizeof(msg) - 1, + "usage: %s -l <linker option> ?<mandatory option> ...?\n" + "Tests for whether link.exe supports an option\n" + "exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]); + WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, + &dwWritten, NULL); + return 2; + } + return CheckForLinkerFeature(&argv[2], argc-2); + case 'f': + if (argc == 2) { + chars = snprintf(msg, sizeof(msg) - 1, + "usage: %s -f <string> <substring>\n" + "Find a substring within another\n" + "exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]); + WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, + &dwWritten, NULL); + return 2; + } else if (argc == 3) { + /* + * If the string is blank, there is no match. + */ + + return 0; + } else { + return IsIn(argv[2], argv[3]); + } + case 's': + if (argc == 2) { + chars = snprintf(msg, sizeof(msg) - 1, + "usage: %s -s <substitutions file> <file>\n" + "Perform a set of string map type substutitions on a file\n" + "exitcodes: 0\n", + argv[0]); + WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, + &dwWritten, NULL); + return 2; + } + return SubstituteFile(argv[2], argv[3]); + case 'V': + if (argc != 4) { + chars = snprintf(msg, sizeof(msg) - 1, + "usage: %s -V filename matchstring\n" + "Extract a version from a file:\n" + "eg: pkgIndex.tcl \"package ifneeded http\"", + argv[0]); + WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, + &dwWritten, NULL); + return 0; + } + printf("%s\n", GetVersionFromFile(argv[2], argv[3], *(argv[1]+2) - '0')); + return 0; + case 'Q': + if (argc != 3) { + chars = snprintf(msg, sizeof(msg) - 1, + "usage: %s -Q path\n" + "Emit the fully qualified path\n" + "exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]); + WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, + &dwWritten, NULL); + return 2; + } + return QualifyPath(argv[2]); + } + } + chars = snprintf(msg, sizeof(msg) - 1, + "usage: %s -c|-f|-l|-Q|-s|-V ...\n" + "This is a little helper app to equalize shell differences between WinNT and\n" + "Win9x and get nmake.exe to accomplish its job.\n", + argv[0]); + WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL); + return 2; +} + +static int +CheckForCompilerFeature( + const char *option) +{ + STARTUPINFO si; + PROCESS_INFORMATION pi; + SECURITY_ATTRIBUTES sa; + DWORD threadID; + char msg[300]; + BOOL ok; + HANDLE hProcess, h, pipeThreads[2]; + char cmdline[100]; + + hProcess = GetCurrentProcess(); + + ZeroMemory(&pi, sizeof(PROCESS_INFORMATION)); + ZeroMemory(&si, sizeof(STARTUPINFO)); + si.cb = sizeof(STARTUPINFO); + si.dwFlags = STARTF_USESTDHANDLES; + si.hStdInput = INVALID_HANDLE_VALUE; + + ZeroMemory(&sa, sizeof(SECURITY_ATTRIBUTES)); + sa.nLength = sizeof(SECURITY_ATTRIBUTES); + sa.lpSecurityDescriptor = NULL; + sa.bInheritHandle = FALSE; + + /* + * Create a non-inheritible pipe. + */ + + CreatePipe(&Out.pipe, &h, &sa, 0); + + /* + * Dupe the write side, make it inheritible, and close the original. + */ + + DuplicateHandle(hProcess, h, hProcess, &si.hStdOutput, 0, TRUE, + DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE); + + /* + * Same as above, but for the error side. + */ + + CreatePipe(&Err.pipe, &h, &sa, 0); + DuplicateHandle(hProcess, h, hProcess, &si.hStdError, 0, TRUE, + DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE); + + /* + * Base command line. + */ + + lstrcpy(cmdline, "cl.exe -nologo -c -TC -Zs -X -Fp.\\_junk.pch "); + + /* + * Append our option for testing + */ + + lstrcat(cmdline, option); + + /* + * Filename to compile, which exists, but is nothing and empty. + */ + + lstrcat(cmdline, " .\\nul"); + + ok = CreateProcess( + NULL, /* Module name. */ + cmdline, /* Command line. */ + NULL, /* Process handle not inheritable. */ + NULL, /* Thread handle not inheritable. */ + TRUE, /* yes, inherit handles. */ + DETACHED_PROCESS, /* No console for you. */ + NULL, /* Use parent's environment block. */ + NULL, /* Use parent's starting directory. */ + &si, /* Pointer to STARTUPINFO structure. */ + &pi); /* Pointer to PROCESS_INFORMATION structure. */ + + if (!ok) { + DWORD err = GetLastError(); + int chars = snprintf(msg, sizeof(msg) - 1, + "Tried to launch: \"%s\", but got error [%u]: ", cmdline, err); + + FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS| + FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPVOID)&msg[chars], + (300-chars), 0); + WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, lstrlen(msg), &err,NULL); + return 2; + } + + /* + * Close our references to the write handles that have now been inherited. + */ + + CloseHandle(si.hStdOutput); + CloseHandle(si.hStdError); + + WaitForInputIdle(pi.hProcess, 5000); + CloseHandle(pi.hThread); + + /* + * Start the pipe reader threads. + */ + + pipeThreads[0] = CreateThread(NULL, 0, ReadFromPipe, &Out, 0, &threadID); + pipeThreads[1] = CreateThread(NULL, 0, ReadFromPipe, &Err, 0, &threadID); + + /* + * Block waiting for the process to end. + */ + + WaitForSingleObject(pi.hProcess, INFINITE); + CloseHandle(pi.hProcess); + + /* + * Wait for our pipe to get done reading, should it be a little slow. + */ + + WaitForMultipleObjects(2, pipeThreads, TRUE, 500); + CloseHandle(pipeThreads[0]); + CloseHandle(pipeThreads[1]); + + /* + * Look for the commandline warning code in both streams. + * - in MSVC 6 & 7 we get D4002, in MSVC 8 we get D9002. + */ + + return !(strstr(Out.buffer, "D4002") != NULL + || strstr(Err.buffer, "D4002") != NULL + || strstr(Out.buffer, "D9002") != NULL + || strstr(Err.buffer, "D9002") != NULL + || strstr(Out.buffer, "D2021") != NULL + || strstr(Err.buffer, "D2021") != NULL); +} + +static int +CheckForLinkerFeature( + const char **options, + int count) +{ + STARTUPINFO si; + PROCESS_INFORMATION pi; + SECURITY_ATTRIBUTES sa; + DWORD threadID; + char msg[300]; + BOOL ok; + HANDLE hProcess, h, pipeThreads[2]; + int i; + char cmdline[255]; + + hProcess = GetCurrentProcess(); + + ZeroMemory(&pi, sizeof(PROCESS_INFORMATION)); + ZeroMemory(&si, sizeof(STARTUPINFO)); + si.cb = sizeof(STARTUPINFO); + si.dwFlags = STARTF_USESTDHANDLES; + si.hStdInput = INVALID_HANDLE_VALUE; + + ZeroMemory(&sa, sizeof(SECURITY_ATTRIBUTES)); + sa.nLength = sizeof(SECURITY_ATTRIBUTES); + sa.lpSecurityDescriptor = NULL; + sa.bInheritHandle = TRUE; + + /* + * Create a non-inheritible pipe. + */ + + CreatePipe(&Out.pipe, &h, &sa, 0); + + /* + * Dupe the write side, make it inheritible, and close the original. + */ + + DuplicateHandle(hProcess, h, hProcess, &si.hStdOutput, 0, TRUE, + DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE); + + /* + * Same as above, but for the error side. + */ + + CreatePipe(&Err.pipe, &h, &sa, 0); + DuplicateHandle(hProcess, h, hProcess, &si.hStdError, 0, TRUE, + DUPLICATE_SAME_ACCESS | DUPLICATE_CLOSE_SOURCE); + + /* + * Base command line. + */ + + lstrcpy(cmdline, "link.exe -nologo "); + + /* + * Append our option for testing. + */ + + for (i = 0; i < count; i++) { + lstrcat(cmdline, " \""); + lstrcat(cmdline, options[i]); + lstrcat(cmdline, "\""); + } + + ok = CreateProcess( + NULL, /* Module name. */ + cmdline, /* Command line. */ + NULL, /* Process handle not inheritable. */ + NULL, /* Thread handle not inheritable. */ + TRUE, /* yes, inherit handles. */ + DETACHED_PROCESS, /* No console for you. */ + NULL, /* Use parent's environment block. */ + NULL, /* Use parent's starting directory. */ + &si, /* Pointer to STARTUPINFO structure. */ + &pi); /* Pointer to PROCESS_INFORMATION structure. */ + + if (!ok) { + DWORD err = GetLastError(); + int chars = snprintf(msg, sizeof(msg) - 1, + "Tried to launch: \"%s\", but got error [%u]: ", cmdline, err); + + FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS| + FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPVOID)&msg[chars], + (300-chars), 0); + WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, lstrlen(msg), &err,NULL); + return 2; + } + + /* + * Close our references to the write handles that have now been inherited. + */ + + CloseHandle(si.hStdOutput); + CloseHandle(si.hStdError); + + WaitForInputIdle(pi.hProcess, 5000); + CloseHandle(pi.hThread); + + /* + * Start the pipe reader threads. + */ + + pipeThreads[0] = CreateThread(NULL, 0, ReadFromPipe, &Out, 0, &threadID); + pipeThreads[1] = CreateThread(NULL, 0, ReadFromPipe, &Err, 0, &threadID); + + /* + * Block waiting for the process to end. + */ + + WaitForSingleObject(pi.hProcess, INFINITE); + CloseHandle(pi.hProcess); + + /* + * Wait for our pipe to get done reading, should it be a little slow. + */ + + WaitForMultipleObjects(2, pipeThreads, TRUE, 500); + CloseHandle(pipeThreads[0]); + CloseHandle(pipeThreads[1]); + + /* + * Look for the commandline warning code in the stderr stream. + */ + + return !(strstr(Out.buffer, "LNK1117") != NULL || + strstr(Err.buffer, "LNK1117") != NULL || + strstr(Out.buffer, "LNK4044") != NULL || + strstr(Err.buffer, "LNK4044") != NULL || + strstr(Out.buffer, "LNK4224") != NULL || + strstr(Err.buffer, "LNK4224") != NULL); +} + +static DWORD WINAPI +ReadFromPipe( + LPVOID args) +{ + pipeinfo *pi = (pipeinfo *) args; + char *lastBuf = pi->buffer; + DWORD dwRead; + BOOL ok; + + again: + if (lastBuf - pi->buffer + CHUNK > STATICBUFFERSIZE) { + CloseHandle(pi->pipe); + return (DWORD)-1; + } + ok = ReadFile(pi->pipe, lastBuf, CHUNK, &dwRead, 0L); + if (!ok || dwRead == 0) { + CloseHandle(pi->pipe); + return 0; + } + lastBuf += dwRead; + goto again; + + return 0; /* makes the compiler happy */ +} + +static int +IsIn( + const char *string, + const char *substring) +{ + return (strstr(string, substring) != NULL); +} + +/* + * GetVersionFromFile -- + * Looks for a match string in a file and then returns the version + * following the match where a version is anything acceptable to + * package provide or package ifneeded. + */ + +static const char * +GetVersionFromFile( + const char *filename, + const char *match, + int numdots) +{ + size_t cbBuffer = 100; + static char szBuffer[100]; + char *szResult = NULL; + FILE *fp = fopen(filename, "rt"); + + if (fp != NULL) { + /* + * Read data until we see our match string. + */ + + while (fgets(szBuffer, cbBuffer, fp) != NULL) { + LPSTR p, q; + + p = strstr(szBuffer, match); + if (p != NULL) { + /* + * Skip to first digit after the match. + */ + + p += strlen(match); + while (*p && !isdigit(*p)) { + ++p; + } + + /* + * Find ending whitespace. + */ + + q = p; + while (*q && (strchr("0123456789.ab", *q)) && ((!strchr(".ab", *q) + && (!strchr("ab", q[-1])) || --numdots))) { + ++q; + } + + memcpy(szBuffer, p, q - p); + szBuffer[q-p] = 0; + szResult = szBuffer; + break; + } + } + fclose(fp); + } + return szResult; +} + +/* + * List helpers for the SubstituteFile function + */ + +typedef struct list_item_t { + struct list_item_t *nextPtr; + char * key; + char * value; +} list_item_t; + +/* insert a list item into the list (list may be null) */ +static list_item_t * +list_insert(list_item_t **listPtrPtr, const char *key, const char *value) +{ + list_item_t *itemPtr = malloc(sizeof(list_item_t)); + if (itemPtr) { + itemPtr->key = strdup(key); + itemPtr->value = strdup(value); + itemPtr->nextPtr = NULL; + + while(*listPtrPtr) { + listPtrPtr = &(*listPtrPtr)->nextPtr; + } + *listPtrPtr = itemPtr; + } + return itemPtr; +} + +static void +list_free(list_item_t **listPtrPtr) +{ + list_item_t *tmpPtr, *listPtr = *listPtrPtr; + while (listPtr) { + tmpPtr = listPtr; + listPtr = listPtr->nextPtr; + free(tmpPtr->key); + free(tmpPtr->value); + free(tmpPtr); + } +} + +/* + * SubstituteFile -- + * As windows doesn't provide anything useful like sed and it's unreliable + * to use the tclsh you are building against (consider x-platform builds - + * eg compiling AMD64 target from IX86) we provide a simple substitution + * option here to handle autoconf style substitutions. + * The substitution file is whitespace and line delimited. The file should + * consist of lines matching the regular expression: + * \s*\S+\s+\S*$ + * + * Usage is something like: + * nmakehlp -S << $** > $@ + * @PACKAGE_NAME@ $(PACKAGE_NAME) + * @PACKAGE_VERSION@ $(PACKAGE_VERSION) + * << + */ + +static int +SubstituteFile( + const char *substitutions, + const char *filename) +{ + size_t cbBuffer = 1024; + static char szBuffer[1024], szCopy[1024]; + char *szResult = NULL; + list_item_t *substPtr = NULL; + FILE *fp, *sp; + + fp = fopen(filename, "rt"); + if (fp != NULL) { + + /* + * Build a list of substutitions from the first filename + */ + + sp = fopen(substitutions, "rt"); + if (sp != NULL) { + while (fgets(szBuffer, cbBuffer, sp) != NULL) { + unsigned char *ks, *ke, *vs, *ve; + ks = (unsigned char*)szBuffer; + while (ks && *ks && isspace(*ks)) ++ks; + ke = ks; + while (ke && *ke && !isspace(*ke)) ++ke; + vs = ke; + while (vs && *vs && isspace(*vs)) ++vs; + ve = vs; + while (ve && *ve && !(*ve == '\r' || *ve == '\n')) ++ve; + *ke = 0, *ve = 0; + list_insert(&substPtr, (char*)ks, (char*)vs); + } + fclose(sp); + } + + /* debug: dump the list */ +#ifdef _DEBUG + { + int n = 0; + list_item_t *p = NULL; + for (p = substPtr; p != NULL; p = p->nextPtr, ++n) { + fprintf(stderr, "% 3d '%s' => '%s'\n", n, p->key, p->value); + } + } +#endif + + /* + * Run the substitutions over each line of the input + */ + + while (fgets(szBuffer, cbBuffer, fp) != NULL) { + list_item_t *p = NULL; + for (p = substPtr; p != NULL; p = p->nextPtr) { + char *m = strstr(szBuffer, p->key); + if (m) { + char *cp, *op, *sp; + cp = szCopy; + op = szBuffer; + while (op != m) *cp++ = *op++; + sp = p->value; + while (sp && *sp) *cp++ = *sp++; + op += strlen(p->key); + while (*op) *cp++ = *op++; + *cp = 0; + memcpy(szBuffer, szCopy, sizeof(szCopy)); + } + } + printf(szBuffer); + } + + list_free(&substPtr); + } + fclose(fp); + return 0; +} + +/* + * QualifyPath -- + * + * This composes the current working directory with a provided path + * and returns the fully qualified and normalized path. + * Mostly needed to setup paths for testing. + */ + +static int +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); + printf("%s\n", szCwd); + return 0; +} + +/* + * Local variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * indent-tabs-mode: t + * tab-width: 8 + * End: + */ diff --git a/win/rules.vc b/win/rules.vc new file mode 100644 index 0000000..4a3ae26 --- /dev/null +++ b/win/rules.vc @@ -0,0 +1,708 @@ +#------------------------------------------------------------------------------
+# rules.vc --
+#
+# Microsoft Visual C++ makefile include for decoding the commandline
+# macros. This file does not need editing to build Tcl.
+#
+# 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
+#------------------------------------------------------------------------------
+
+!ifndef _RULES_VC
+_RULES_VC = 1
+
+cc32 = $(CC) # built-in default.
+link32 = link
+lib32 = lib
+rc32 = $(RC) # built-in default.
+
+!ifndef INSTALLDIR
+### Assume the normal default.
+_INSTALLDIR = C:\Program Files\Tcl
+!else
+### Fix the path separators.
+_INSTALLDIR = $(INSTALLDIR:/=\)
+!endif
+
+#----------------------------------------------------------
+# 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
+COPY = copy /y >NUL
+!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
+
+#------------------------------------------------------------------------------
+# Determine the host and target architectures and compiler version.
+#------------------------------------------------------------------------------
+
+_HASH=^#
+_VC_MANIFEST_EMBED_EXE=
+_VC_MANIFEST_EMBED_DLL=
+VCVER=0
+!if ![echo VCVERSION=_MSC_VER > vercl.x] \
+ && ![echo $(_HASH)if defined(_M_IX86) >> vercl.x] \
+ && ![echo ARCH=IX86 >> vercl.x] \
+ && ![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)]
+!include vercl.i
+!if ![echo VCVER= ^\> vercl.vc] \
+ && ![set /a $(VCVERSION) / 100 - 6 >> vercl.vc]
+!include vercl.vc
+!endif
+!endif
+!if ![del $(ERRNUL) /q/f vercl.x vercl.i vercl.vc]
+!endif
+
+!if ![reg query HKLM\Hardware\Description\System\CentralProcessor\0 /v Identifier | findstr /i x86]
+NATIVE_ARCH=IX86
+!else
+NATIVE_ARCH=AMD64
+!endif
+
+# Since MSVC8 we must deal with manifest resources.
+!if $(VCVERSION) >= 1400
+_VC_MANIFEST_EMBED_EXE=if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;1
+_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 ===============================================================================
+
+#----------------------------------------------------------
+# build the helper app we need to overcome nmake's limiting
+# environment.
+#----------------------------------------------------------
+
+!if !exist(nmakehlp.exe)
+!if [$(cc32) -nologo nmakehlp.c -link -subsystem:console > nul]
+!endif
+!endif
+
+#----------------------------------------------------------
+# Test for compiler features
+#----------------------------------------------------------
+
+### test for optimizations
+!if [nmakehlp -c -Ot]
+!message *** Compiler has 'Optimizations'
+OPTIMIZING = 1
+!else
+!message *** Compiler does not have 'Optimizations'
+OPTIMIZING = 0
+!endif
+
+OPTIMIZATIONS =
+
+!if [nmakehlp -c -Ot]
+OPTIMIZATIONS = $(OPTIMIZATIONS) -Ot
+!endif
+
+!if [nmakehlp -c -Oi]
+OPTIMIZATIONS = $(OPTIMIZATIONS) -Oi
+!endif
+
+!if [nmakehlp -c -Op]
+OPTIMIZATIONS = $(OPTIMIZATIONS) -Op
+!endif
+
+!if [nmakehlp -c -fp:strict]
+OPTIMIZATIONS = $(OPTIMIZATIONS) -fp:strict
+!endif
+
+!if [nmakehlp -c -Gs]
+OPTIMIZATIONS = $(OPTIMIZATIONS) -Gs
+!endif
+
+!if [nmakehlp -c -GS]
+OPTIMIZATIONS = $(OPTIMIZATIONS) -GS
+!endif
+
+!if [nmakehlp -c -GL]
+OPTIMIZATIONS = $(OPTIMIZATIONS) -GL
+!endif
+
+DEBUGFLAGS =
+
+!if [nmakehlp -c -RTC1]
+DEBUGFLAGS = $(DEBUGFLAGS) -RTC1
+!elseif [nmakehlp -c -GZ]
+DEBUGFLAGS = $(DEBUGFLAGS) -GZ
+!endif
+
+COMPILERFLAGS =-W3 /DUNICODE /D_UNICODE /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
+
+# Prevents "LNK1561: entry point must be defined" error compiling from VS-IDE:
+!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
+!endif
+
+LINKERFLAGS =
+
+!if [nmakehlp -l -ltcg $(LINKER_TESTFLAGS)]
+LINKERFLAGS =-ltcg
+!endif
+
+#----------------------------------------------------------
+# Decode the options requested.
+#----------------------------------------------------------
+
+!if "$(OPTS)" == "" || [nmakehlp -f "$(OPTS)" "none"]
+STATIC_BUILD = 0
+TCL_THREADS = 1
+DEBUG = 0
+SYMBOLS = 0
+PROFILE = 0
+PGO = 0
+MSVCRT = 1
+LOIMPACT = 0
+TCL_USE_STATIC_PACKAGES = 0
+USE_THREAD_ALLOC = 1
+UNCHECKED = 0
+!else
+!if [nmakehlp -f $(OPTS) "static"]
+!message *** Doing static
+STATIC_BUILD = 1
+!else
+STATIC_BUILD = 0
+!endif
+!if [nmakehlp -f $(OPTS) "nomsvcrt"]
+!message *** Doing nomsvcrt
+MSVCRT = 0
+!else
+!if [nmakehlp -f $(OPTS) "msvcrt"]
+!message *** Doing msvcrt
+MSVCRT = 1
+!else
+!if !$(STATIC_BUILD)
+MSVCRT = 1
+!else
+MSVCRT = 0
+!endif
+!endif
+!endif
+!if [nmakehlp -f $(OPTS) "staticpkg"] && $(STATIC_BUILD)
+!message *** Doing staticpkg
+TCL_USE_STATIC_PACKAGES = 1
+!else
+TCL_USE_STATIC_PACKAGES = 0
+!endif
+!if [nmakehlp -f $(OPTS) "nothreads"]
+!message *** Compile explicitly for non-threaded tcl
+TCL_THREADS = 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
+!elseif [nmakehlp -f $(OPTS) "pgo"]
+!message *** Doing profile guided optimization
+PGO = 2
+!else
+PGO = 0
+!endif
+!if [nmakehlp -f $(OPTS) "loimpact"]
+!message *** Doing loimpact
+LOIMPACT = 1
+!else
+LOIMPACT = 0
+!endif
+!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
+!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.
+#----------------------------------------------------------
+
+#----------------------------------------
+# Naming convention:
+# 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.
+#----------------------------------------
+SUFX = tsgx
+
+!if $(DEBUG)
+BUILDDIRTOP = Debug
+!else
+BUILDDIRTOP = Release
+!endif
+
+!if "$(MACHINE)" != "IX86"
+BUILDDIRTOP =$(BUILDDIRTOP)_$(MACHINE)
+!endif
+!if $(VCVER) > 6
+BUILDDIRTOP =$(BUILDDIRTOP)_VC$(VCVER)
+!endif
+
+!if !$(DEBUG) || $(DEBUG) && $(UNCHECKED)
+SUFX = $(SUFX:g=)
+!endif
+
+TMP_DIRFULL = .\$(BUILDDIRTOP)\$(PROJECT)_ThreadedDynamicStaticX
+
+!if !$(STATIC_BUILD)
+TMP_DIRFULL = $(TMP_DIRFULL:Static=)
+SUFX = $(SUFX:s=)
+EXT = dll
+TMP_DIRFULL = $(TMP_DIRFULL:X=)
+SUFX = $(SUFX:x=)
+!else
+TMP_DIRFULL = $(TMP_DIRFULL:Dynamic=)
+EXT = lib
+!if !$(MSVCRT)
+TMP_DIRFULL = $(TMP_DIRFULL:X=)
+SUFX = $(SUFX:x=)
+!endif
+!endif
+
+!if !$(TCL_THREADS)
+TMP_DIRFULL = $(TMP_DIRFULL:Threaded=)
+SUFX = $(SUFX:t=)
+!endif
+
+!ifndef TMP_DIR
+TMP_DIR = $(TMP_DIRFULL)
+!ifndef OUT_DIR
+OUT_DIR = .\$(BUILDDIRTOP)
+!endif
+!else
+!ifndef OUT_DIR
+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
+!endif
+!endif
+
+
+#----------------------------------------------------------
+# Decode the checks requested.
+#----------------------------------------------------------
+
+!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
+!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
+!else
+WARNINGS = -W3
+!endif
+!if [nmakehlp -f $(CHECKS) "64bit"] && [nmakehlp -c -Wp64]
+!message *** Doing 64bit portability warnings
+WARNINGS = $(WARNINGS) -Wp64
+!endif
+!endif
+
+!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
+
+#----------------------------------------------------------
+# Set our defines now armed with our options.
+#----------------------------------------------------------
+
+OPTDEFINES = -DTCL_CFGVAL_ENCODING=$(CFG_ENCODING) -DSTDC_HEADERS
+
+!if $(TCL_MEM_DEBUG)
+OPTDEFINES = $(OPTDEFINES) -DTCL_MEM_DEBUG
+!endif
+!if $(TCL_COMPILE_DEBUG)
+OPTDEFINES = $(OPTDEFINES) -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS
+!endif
+!if $(TCL_THREADS)
+OPTDEFINES = $(OPTDEFINES) -DTCL_THREADS=1
+!if $(USE_THREAD_ALLOC)
+OPTDEFINES = $(OPTDEFINES) -DUSE_THREAD_ALLOC=1
+!endif
+!endif
+!if $(STATIC_BUILD)
+OPTDEFINES = $(OPTDEFINES) -DSTATIC_BUILD
+!endif
+!if $(TCL_NO_DEPRECATED)
+OPTDEFINES = $(OPTDEFINES) -DTCL_NO_DEPRECATED
+!endif
+
+!if !$(DEBUG)
+OPTDEFINES = $(OPTDEFINES) -DNDEBUG
+!if $(OPTIMIZING)
+OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_OPTIMIZED
+!endif
+!endif
+!if $(PROFILE)
+OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_PROFILED
+!endif
+!if "$(MACHINE)" == "IA64" || "$(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
+
+!else
+
+# If INSTALLDIR set to tcl root dir then reset to the lib dir.
+!if exist("$(_INSTALLDIR)\include\tcl.h")
+_INSTALLDIR=$(_INSTALLDIR)\lib
+!endif
+
+!if !defined(TCLDIR)
+!if exist("$(_INSTALLDIR)\..\include\tcl.h")
+TCLINSTALL = 1
+_TCLDIR = $(_INSTALLDIR)\..
+_TCL_H = $(_INSTALLDIR)\..\include\tcl.h
+TCLDIR = $(_INSTALLDIR)\..
+!else
+MSG=^
+Failed to find tcl.h. Set the TCLDIR macro.
+!error $(MSG)
+!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
+!else
+MSG =^
+Failed to find tcl.h. The TCLDIR macro does not appear correct.
+!error $(MSG)
+!endif
+!endif
+!endif
+
+#--------------------------------------------------------------
+# Extract various version numbers from tcl headers
+# The generated file is then included in the makefile.
+#--------------------------------------------------------------
+
+!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 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]
+!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
+!endif
+
+!include versions.vc
+
+#--------------------------------------------------------------
+# Setup tcl version dependent stuff headers
+#--------------------------------------------------------------
+
+!if "$(PROJECT)" != "tcl"
+
+TCL_VERSION = $(TCL_MAJOR_VERSION)$(TCL_MINOR_VERSION)
+
+!if $(TCLINSTALL)
+TCLSH = "$(_TCLDIR)\bin\tclsh$(TCL_VERSION)$(SUFX).exe"
+!if !exist($(TCLSH)) && $(TCL_THREADS)
+TCLSH = "$(_TCLDIR)\bin\tclsh$(TCL_VERSION)t$(SUFX).exe"
+!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
+
+!endif
+
+#-------------------------------------------------------------------------
+# Locate the Tk headers to build against
+#-------------------------------------------------------------------------
+
+!if "$(PROJECT)" == "tk"
+_TK_H = ..\generic\tk.h
+_INSTALLDIR = $(_INSTALLDIR)\..
+!endif
+
+!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)
+!endif
+!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
+!endif
+
+#-------------------------------------------------------------------------
+# Extract Tk version numbers
+#-------------------------------------------------------------------------
+
+!if defined(PROJECT_REQUIRES_TK) || "$(PROJECT)" == "tk"
+
+!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
+
+!include versions.vc
+
+TK_DOTVERSION = $(TK_MAJOR_VERSION).$(TK_MINOR_VERSION)
+TK_VERSION = $(TK_MAJOR_VERSION)$(TK_MINOR_VERSION)
+
+!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"
+!endif
+!endif
+
+!endif
+
+#----------------------------------------------------------
+# Display stats being used.
+#----------------------------------------------------------
+
+!message *** Intermediate directory will be '$(TMP_DIR)'
+!message *** Output directory will be '$(OUT_DIR)'
+!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)'
+
+!endif
diff --git a/win/tcl.dsp b/win/tcl.dsp new file mode 100644 index 0000000..48eae9d --- /dev/null +++ b/win/tcl.dsp @@ -0,0 +1,1563 @@ +# Microsoft Developer Studio Project File - Name="tcl" - Package Owner=<4>
+# Microsoft Developer Studio Generated Build File, Format Version 6.00
+# ** DO NOT EDIT **
+
+# TARGTYPE "Win32 (x86) External Target" 0x0106
+
+CFG=tcl - Win32 Debug Static
+!MESSAGE This is not a valid makefile. To build this project using NMAKE,
+!MESSAGE use the Export Makefile command and run
+!MESSAGE
+!MESSAGE NMAKE /f "tcl.mak".
+!MESSAGE
+!MESSAGE You can specify a configuration when running NMAKE
+!MESSAGE by defining the macro CFG on the command line. For example:
+!MESSAGE
+!MESSAGE NMAKE /f "tcl.mak" CFG="tcl - Win32 Debug Static"
+!MESSAGE
+!MESSAGE Possible choices for configuration are:
+!MESSAGE
+!MESSAGE "tcl - Win32 Release" (based on "Win32 (x86) External Target")
+!MESSAGE "tcl - Win32 Debug" (based on "Win32 (x86) External Target")
+!MESSAGE "tcl - Win32 Debug Static" (based on "Win32 (x86) External Target")
+!MESSAGE "tcl - Win32 Release Static" (based on "Win32 (x86) External Target")
+!MESSAGE
+
+# Begin Project
+# PROP AllowPerConfigDependencies 0
+# PROP Scc_ProjName ""
+# PROP Scc_LocalPath ""
+
+!IF "$(CFG)" == "tcl - Win32 Release"
+
+# PROP BASE Use_MFC 0
+# PROP BASE Use_Debug_Libraries 0
+# PROP BASE Output_Dir "Release"
+# 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\tclsh87.exe"
+# PROP BASE Bsc_Name ""
+# PROP BASE Target_Dir ""
+# PROP Use_MFC 0
+# PROP Use_Debug_Libraries 0
+# PROP Output_Dir "Release"
+# 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\tclsh87t.exe"
+# PROP Bsc_Name ""
+# PROP Target_Dir ""
+
+!ELSEIF "$(CFG)" == "tcl - Win32 Debug"
+
+# PROP BASE Use_MFC 0
+# PROP BASE Use_Debug_Libraries 1
+# PROP BASE Output_Dir "Debug"
+# 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\tclsh87g.exe"
+# PROP BASE Bsc_Name ""
+# PROP BASE Target_Dir ""
+# PROP Use_MFC 0
+# PROP Use_Debug_Libraries 1
+# PROP Output_Dir "Debug"
+# 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\tclsh87tg.exe"
+# PROP Bsc_Name ""
+# PROP Target_Dir ""
+
+!ELSEIF "$(CFG)" == "tcl - Win32 Debug Static"
+
+# PROP BASE Use_MFC 0
+# PROP BASE Use_Debug_Libraries 1
+# PROP BASE Output_Dir "Debug"
+# 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\tclsh87sg.exe"
+# PROP BASE Bsc_Name ""
+# PROP BASE Target_Dir ""
+# PROP Use_MFC 0
+# PROP Use_Debug_Libraries 1
+# PROP Output_Dir "Debug"
+# 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\tclsh87sg.exe"
+# PROP Bsc_Name ""
+# PROP Target_Dir ""
+
+!ELSEIF "$(CFG)" == "tcl - Win32 Release Static"
+
+# PROP BASE Use_MFC 0
+# PROP BASE Use_Debug_Libraries 0
+# PROP BASE Output_Dir "Release"
+# 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\tclsh87s.exe"
+# PROP BASE Bsc_Name ""
+# PROP BASE Target_Dir ""
+# PROP Use_MFC 0
+# PROP Use_Debug_Libraries 0
+# PROP Output_Dir "Release"
+# 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\tclsh87s.exe"
+# PROP Bsc_Name ""
+# PROP Target_Dir ""
+
+!ENDIF
+
+# Begin Target
+
+# Name "tcl - Win32 Release"
+# Name "tcl - Win32 Debug"
+# Name "tcl - Win32 Debug Static"
+# Name "tcl - Win32 Release Static"
+
+!IF "$(CFG)" == "tcl - Win32 Release"
+
+!ELSEIF "$(CFG)" == "tcl - Win32 Debug"
+
+!ELSEIF "$(CFG)" == "tcl - Win32 Debug Static"
+
+!ELSEIF "$(CFG)" == "tcl - Win32 Release Static"
+
+!ENDIF
+
+# Begin Group "compat"
+
+# PROP Default_Filter ""
+# Begin Source File
+
+SOURCE=..\compat\dirent.h
+# End Source File
+# Begin Source File
+
+SOURCE=..\compat\dirent2.h
+# End Source File
+# Begin Source File
+
+SOURCE=..\compat\dlfcn.h
+# End Source File
+# Begin Source File
+
+SOURCE=..\compat\fixstrtod.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\compat\float.h
+# End Source File
+# Begin Source File
+
+SOURCE=..\compat\gettod.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\compat\limits.h
+# End Source File
+# Begin Source File
+
+SOURCE=..\compat\memcmp.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\compat\opendir.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\compat\README
+# End Source File
+# Begin Source File
+
+SOURCE=..\compat\stdlib.h
+# End Source File
+# Begin Source File
+
+SOURCE=..\compat\string.h
+# End Source File
+# Begin Source File
+
+SOURCE=..\compat\strncasecmp.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\compat\strstr.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\compat\strtod.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\compat\strtol.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\compat\strtoul.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\compat\tclErrno.h
+# End Source File
+# Begin Source File
+
+SOURCE=..\compat\unistd.h
+# End Source File
+# Begin Source File
+
+SOURCE=..\compat\waitpid.c
+# End Source File
+# End Group
+# Begin Group "doc"
+
+# PROP Default_Filter ""
+# Begin Source File
+
+SOURCE=..\doc\Access.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\AddErrInfo.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\after.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\Alloc.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\AllowExc.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\append.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\AppInit.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\array.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\AssocData.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\Async.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\BackgdErr.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\Backslash.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\bgerror.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\binary.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\BoolObj.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\break.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\ByteArrObj.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\CallDel.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\case.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\catch.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\cd.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\ChnlStack.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\clock.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\close.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\CmdCmplt.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\Concat.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\concat.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\continue.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\CrtChannel.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\CrtChnlHdlr.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\CrtCloseHdlr.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\CrtCommand.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\CrtFileHdlr.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\CrtInterp.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\CrtMathFnc.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\CrtObjCmd.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\CrtSlave.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\CrtTimerHdlr.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\CrtTrace.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\dde.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\DetachPids.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\DoOneEvent.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\DoubleObj.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\DoWhenIdle.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\DString.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\DumpActiveMemory.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\Encoding.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\encoding.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\Environment.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\eof.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\error.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\Eval.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\eval.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\exec.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\Exit.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\exit.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\expr.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\ExprLong.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\ExprLongObj.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\fblocked.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\fconfigure.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\fcopy.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\file.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\fileevent.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\filename.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\FileSystem.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\FindExec.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\flush.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\for.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\foreach.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\format.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\GetCwd.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\GetHostName.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\GetIndex.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\GetInt.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\GetOpnFl.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\gets.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\GetStdChan.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\GetVersion.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\glob.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\global.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\Hash.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\history.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\http.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\if.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\incr.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\info.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\Init.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\InitStubs.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\Interp.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\interp.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\IntObj.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\join.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\lappend.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\library.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\lindex.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\LinkVar.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\linsert.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\list.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\ListObj.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\llength.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\load.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\lrange.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\lreplace.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\lsearch.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\lsort.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\man.macros
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\memory.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\msgcat.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\namespace.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\Notifier.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\Object.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\ObjectType.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\open.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\OpenFileChnl.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\OpenTcp.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\package.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\packagens.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\Panic.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\ParseCmd.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\pid.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\pkgMkIndex.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\PkgRequire.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\Preserve.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\PrintDbl.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\proc.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\puts.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\pwd.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\re_syntax.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\read.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\RecEvalObj.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\RecordEval.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\RegExp.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\regexp.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\registry.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\regsub.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\rename.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\return.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\safe.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\SaveResult.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\scan.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\seek.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\set.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\SetErrno.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\SetRecLmt.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\SetResult.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\SetVar.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\Signal.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\Sleep.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\socket.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\source.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\SourceRCFile.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\split.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\SplitList.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\SplitPath.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\StaticPkg.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\StdChannels.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\string.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\StringObj.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\StrMatch.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\subst.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\SubstObj.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\switch.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\Tcl.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\Tcl_Main.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\TCL_MEM_DEBUG.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\tclsh.1
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\tcltest.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\tclvars.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\tell.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\Thread.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\time.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\ToUpper.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\trace.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\TraceVar.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\Translate.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\UniCharIsAlpha.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\unknown.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\unset.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\update.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\uplevel.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\UpVar.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\upvar.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\Utf.3
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\variable.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\vwait.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\while.n
+# End Source File
+# Begin Source File
+
+SOURCE=..\doc\WrongNumArgs.3
+# End Source File
+# End Group
+# Begin Group "generic"
+
+# PROP Default_Filter ""
+# Begin Source File
+
+SOURCE=..\generic\README
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\regc_color.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\regc_cvec.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\regc_lex.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\regc_locale.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\regc_nfa.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\regcomp.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\regcustom.h
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\rege_dfa.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\regerror.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\regerrs.h
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\regex.h
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\regexec.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\regfree.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\regfronts.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\regguts.h
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tcl.decls
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tcl.h
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclAlloc.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclAsync.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclBasic.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclBinary.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclCkalloc.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclClock.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclCmdAH.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclCmdIL.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclCmdMZ.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclCompCmds.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclCompExpr.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclCompile.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclCompile.h
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclDate.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclDecls.h
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclEncoding.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclEnv.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclEvent.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclExecute.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclFCmd.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclFileName.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclGet.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclGetDate.y
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclHash.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclHistory.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclIndexObj.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclInt.decls
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclInt.h
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclIntDecls.h
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclInterp.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclIntPlatDecls.h
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclIO.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclIO.h
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclIOCmd.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclIOGT.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclIOSock.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclIOUtil.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclLink.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclListObj.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclLiteral.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclLoad.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclLoadNone.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclMain.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclNamesp.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclNotify.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclObj.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclPanic.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclParse.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclPipe.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclPkg.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclPlatDecls.h
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclPort.h
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclPosixStr.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclPreserve.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclProc.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclRegexp.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclRegexp.h
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclResolve.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclResult.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclScan.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclStringObj.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclStubInit.c
+# End Source File
+# Begin Source File
+
+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
+
+SOURCE=..\generic\tclTestObj.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclTestProcBodyObj.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclThread.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclThreadJoin.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclThreadTest.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclTimer.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclUniData.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclUtf.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclUtil.c
+# End Source File
+# Begin Source File
+
+SOURCE=..\generic\tclVar.c
+# End Source File
+# End Group
+# Begin Group "library"
+
+# PROP Default_Filter ""
+# Begin Source File
+
+SOURCE=..\library\auto.tcl
+# End Source File
+# Begin Source File
+
+SOURCE=..\library\history.tcl
+# End Source File
+# Begin Source File
+
+SOURCE=..\library\init.tcl
+# End Source File
+# Begin Source File
+
+SOURCE=..\library\ldAout.tcl
+# End Source File
+# Begin Source File
+
+SOURCE=..\library\package.tcl
+# End Source File
+# Begin Source File
+
+SOURCE=..\library\parray.tcl
+# End Source File
+# Begin Source File
+
+SOURCE=..\library\safe.tcl
+# End Source File
+# Begin Source File
+
+SOURCE=..\library\tclIndex
+# End Source File
+# Begin Source File
+
+SOURCE=..\library\word.tcl
+# End Source File
+# End Group
+# Begin Group "mac"
+
+# PROP Default_Filter ""
+# End Group
+# Begin Group "tests"
+
+# PROP Default_Filter ""
+# End Group
+# Begin Group "tools"
+
+# PROP Default_Filter ""
+# End Group
+# Begin Group "unix"
+
+# PROP Default_Filter ""
+# End Group
+# Begin Group "win"
+
+# PROP Default_Filter ""
+# Begin Source File
+
+SOURCE=.\aclocal.m4
+# End Source File
+# Begin Source File
+
+SOURCE=.\cat.c
+# End Source File
+# Begin Source File
+
+SOURCE=.\configure
+# End Source File
+# Begin Source File
+
+SOURCE=.\configure.ac
+# End Source File
+# Begin Source File
+
+SOURCE=.\Makefile.in
+# End Source File
+# Begin Source File
+
+SOURCE=.\makefile.vc
+# End Source File
+# Begin Source File
+
+SOURCE=.\mkd.bat
+# End Source File
+# Begin Source File
+
+SOURCE=.\README
+# End Source File
+# Begin Source File
+
+SOURCE=.\README.binary
+# End Source File
+# Begin Source File
+
+SOURCE=.\rmd.bat
+# End Source File
+# Begin Source File
+
+SOURCE=.\rules.vc
+# End Source File
+# Begin Source File
+
+SOURCE=.\tcl.hpj.in
+# End Source File
+# Begin Source File
+
+SOURCE=.\tcl.m4
+# End Source File
+# Begin Source File
+
+SOURCE=.\tcl.rc
+# End Source File
+# Begin Source File
+
+SOURCE=.\tclAppInit.c
+# End Source File
+# Begin Source File
+
+SOURCE=.\tclConfig.sh.in
+# End Source File
+# Begin Source File
+
+SOURCE=.\tclsh.ico
+# End Source File
+# Begin Source File
+
+SOURCE=.\tclsh.rc
+# End Source File
+# Begin Source File
+
+SOURCE=.\tclWin32Dll.c
+# End Source File
+# Begin Source File
+
+SOURCE=.\tclWinChan.c
+# End Source File
+# Begin Source File
+
+SOURCE=.\tclWinConsole.c
+# End Source File
+# Begin Source File
+
+SOURCE=.\tclWinDde.c
+# End Source File
+# Begin Source File
+
+SOURCE=.\tclWinError.c
+# End Source File
+# Begin Source File
+
+SOURCE=.\tclWinFCmd.c
+# End Source File
+# Begin Source File
+
+SOURCE=.\tclWinFile.c
+# End Source File
+# Begin Source File
+
+SOURCE=.\tclWinInit.c
+# End Source File
+# Begin Source File
+
+SOURCE=.\tclWinInt.h
+# End Source File
+# Begin Source File
+
+SOURCE=.\tclWinLoad.c
+# End Source File
+# Begin Source File
+
+SOURCE=.\tclWinNotify.c
+# End Source File
+# Begin Source File
+
+SOURCE=.\tclWinPipe.c
+# End Source File
+# Begin Source File
+
+SOURCE=.\tclWinPort.h
+# End Source File
+# Begin Source File
+
+SOURCE=.\tclWinReg.c
+# End Source File
+# Begin Source File
+
+SOURCE=.\tclWinSerial.c
+# End Source File
+# Begin Source File
+
+SOURCE=.\tclWinSock.c
+# End Source File
+# Begin Source File
+
+SOURCE=.\tclWinTest.c
+# End Source File
+# Begin Source File
+
+SOURCE=.\tclWinThrd.c
+# End Source File
+# Begin Source File
+
+SOURCE=.\tclWinTime.c
+# End Source File
+# End Group
+# End Target
+# End Project
diff --git a/win/tcl.dsw b/win/tcl.dsw new file mode 100644 index 0000000..1c16fad --- /dev/null +++ b/win/tcl.dsw @@ -0,0 +1,29 @@ +Microsoft Developer Studio Workspace File, Format Version 6.00
+# WARNING: DO NOT EDIT OR DELETE THIS WORKSPACE FILE!
+
+###############################################################################
+
+Project: "tcl"=.\tcl.dsp - Package Owner=<4>
+
+Package=<5>
+{{{
+}}}
+
+Package=<4>
+{{{
+}}}
+
+###############################################################################
+
+Global:
+
+Package=<5>
+{{{
+}}}
+
+Package=<3>
+{{{
+}}}
+
+###############################################################################
+
diff --git a/win/tcl.hpj.in b/win/tcl.hpj.in new file mode 100644 index 0000000..a94cea6 --- /dev/null +++ b/win/tcl.hpj.in @@ -0,0 +1,19 @@ +; This file is maintained by HCW. Do not modify this file directly.
+
+[OPTIONS]
+HCW=0
+LCID=0x409 0x0 0x0 ;English (United States)
+REPORT=Yes
+TITLE=Tcl/Tk Reference Manual
+CNT=tcl86.cnt
+COPYRIGHT=Copyright © 2000 Ajuba Solutions
+HLP=tcl86.hlp
+
+[FILES]
+tcl.rtf
+
+[WINDOWS]
+main="Tcl/Tk Reference Manual",,0
+
+[CONFIG]
+BrowseButtons()
diff --git a/win/tcl.m4 b/win/tcl.m4 new file mode 100644 index 0000000..b4fbcce --- /dev/null +++ b/win/tcl.m4 @@ -0,0 +1,1299 @@ +#------------------------------------------------------------------------ +# SC_PATH_TCLCONFIG -- +# +# Locate the tclConfig.sh file and perform a sanity check on +# the Tcl compile flags +# +# Arguments: +# none +# +# Results: +# +# Adds the following arguments to configure: +# --with-tcl=... +# +# Defines the following vars: +# TCL_BIN_DIR Full path to the directory containing +# the tclConfig.sh file +#------------------------------------------------------------------------ + +AC_DEFUN([SC_PATH_TCLCONFIG], [ + # + # Ok, lets find the tcl configuration + # First, look for one uninstalled. + # the alternative search directory is invoked by --with-tcl + # + + if test x"${no_tcl}" = x ; then + # we reset no_tcl in case something fails here + no_tcl=true + AC_ARG_WITH(tcl, + AC_HELP_STRING([--with-tcl], + [directory containing tcl configuration (tclConfig.sh)]), + with_tclconfig="${withval}") + AC_MSG_CHECKING([for Tcl configuration]) + AC_CACHE_VAL(ac_cv_c_tclconfig,[ + + # First check to see if --with-tcl was specified. + if test x"${with_tclconfig}" != x ; then + case "${with_tclconfig}" in + */tclConfig.sh ) + if test -f "${with_tclconfig}"; then + AC_MSG_WARN([--with-tcl argument should refer to directory containing tclConfig.sh, not to tclConfig.sh itself]) + with_tclconfig="`echo "${with_tclconfig}" | sed 's!/tclConfig\.sh$!!'`" + fi ;; + esac + if test -f "${with_tclconfig}/tclConfig.sh" ; then + ac_cv_c_tclconfig="`(cd "${with_tclconfig}"; pwd)`" + else + AC_MSG_ERROR([${with_tclconfig} directory doesn't contain tclConfig.sh]) + fi + fi + + # then check for a private Tcl installation + if test x"${ac_cv_c_tclconfig}" = x ; then + for i in \ + ../tcl \ + `ls -dr ../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ + `ls -dr ../tcl[[8-9]].[[0-9]] 2>/dev/null` \ + `ls -dr ../tcl[[8-9]].[[0-9]]* 2>/dev/null` \ + ../../tcl \ + `ls -dr ../../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ + `ls -dr ../../tcl[[8-9]].[[0-9]] 2>/dev/null` \ + `ls -dr ../../tcl[[8-9]].[[0-9]]* 2>/dev/null` \ + ../../../tcl \ + `ls -dr ../../../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ + `ls -dr ../../../tcl[[8-9]].[[0-9]] 2>/dev/null` \ + `ls -dr ../../../tcl[[8-9]].[[0-9]]* 2>/dev/null` ; do + if test -f "$i/win/tclConfig.sh" ; then + ac_cv_c_tclconfig="`(cd $i/win; pwd)`" + break + fi + done + fi + + # check in a few common install locations + if test x"${ac_cv_c_tclconfig}" = x ; then + for i in `ls -d ${libdir} 2>/dev/null` \ + `ls -d ${exec_prefix}/lib 2>/dev/null` \ + `ls -d ${prefix}/lib 2>/dev/null` \ + `ls -d /cygdrive/c/Tcl/lib 2>/dev/null` \ + `ls -d /cygdrive/c/Progra~1/Tcl/lib 2>/dev/null` \ + `ls -d /c/Tcl/lib 2>/dev/null` \ + `ls -d /c/Progra~1/Tcl/lib 2>/dev/null` \ + `ls -d C:/Tcl/lib 2>/dev/null` \ + `ls -d C:/Progra~1/Tcl/lib 2>/dev/null` \ + ; do + if test -f "$i/tclConfig.sh" ; then + ac_cv_c_tclconfig="`(cd $i; pwd)`" + break + fi + done + fi + + # check in a few other private locations + if test x"${ac_cv_c_tclconfig}" = x ; then + for i in \ + ${srcdir}/../tcl \ + `ls -dr ${srcdir}/../tcl[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ + `ls -dr ${srcdir}/../tcl[[8-9]].[[0-9]] 2>/dev/null` \ + `ls -dr ${srcdir}/../tcl[[8-9]].[[0-9]]* 2>/dev/null` ; do + if test -f "$i/win/tclConfig.sh" ; then + ac_cv_c_tclconfig="`(cd $i/win; pwd)`" + break + fi + done + fi + ]) + + if test x"${ac_cv_c_tclconfig}" = x ; then + TCL_BIN_DIR="# no Tcl configs found" + AC_MSG_ERROR([Can't find Tcl configuration definitions. Use --with-tcl to specify a directory containing tclConfig.sh]) + else + no_tcl= + TCL_BIN_DIR="${ac_cv_c_tclconfig}" + AC_MSG_RESULT([found ${TCL_BIN_DIR}/tclConfig.sh]) + fi + fi +]) + +#------------------------------------------------------------------------ +# SC_PATH_TKCONFIG -- +# +# Locate the tkConfig.sh file +# +# Arguments: +# none +# +# Results: +# +# Adds the following arguments to configure: +# --with-tk=... +# +# Defines the following vars: +# TK_BIN_DIR Full path to the directory containing +# the tkConfig.sh file +#------------------------------------------------------------------------ + +AC_DEFUN([SC_PATH_TKCONFIG], [ + # + # Ok, lets find the tk configuration + # First, look for one uninstalled. + # the alternative search directory is invoked by --with-tk + # + + if test x"${no_tk}" = x ; then + # we reset no_tk in case something fails here + no_tk=true + AC_ARG_WITH(tk, + AC_HELP_STRING([--with-tk], + [directory containing tk configuration (tkConfig.sh)]), + with_tkconfig="${withval}") + AC_MSG_CHECKING([for Tk configuration]) + AC_CACHE_VAL(ac_cv_c_tkconfig,[ + + # First check to see if --with-tkconfig was specified. + if test x"${with_tkconfig}" != x ; then + case "${with_tkconfig}" in + */tkConfig.sh ) + if test -f "${with_tkconfig}"; then + AC_MSG_WARN([--with-tk argument should refer to directory containing tkConfig.sh, not to tkConfig.sh itself]) + with_tkconfig="`echo "${with_tkconfig}" | sed 's!/tkConfig\.sh$!!'`" + fi ;; + esac + if test -f "${with_tkconfig}/tkConfig.sh" ; then + ac_cv_c_tkconfig="`(cd "${with_tkconfig}"; pwd)`" + else + AC_MSG_ERROR([${with_tkconfig} directory doesn't contain tkConfig.sh]) + fi + fi + + # then check for a private Tk library + if test x"${ac_cv_c_tkconfig}" = x ; then + for i in \ + ../tk \ + `ls -dr ../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ + `ls -dr ../tk[[8-9]].[[0-9]] 2>/dev/null` \ + `ls -dr ../tk[[8-9]].[[0-9]]* 2>/dev/null` \ + ../../tk \ + `ls -dr ../../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ + `ls -dr ../../tk[[8-9]].[[0-9]] 2>/dev/null` \ + `ls -dr ../../tk[[8-9]].[[0-9]]* 2>/dev/null` \ + ../../../tk \ + `ls -dr ../../../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ + `ls -dr ../../../tk[[8-9]].[[0-9]] 2>/dev/null` \ + `ls -dr ../../../tk[[8-9]].[[0-9]]* 2>/dev/null` ; do + if test -f "$i/win/tkConfig.sh" ; then + ac_cv_c_tkconfig="`(cd $i/win; pwd)`" + break + fi + done + fi + + # check in a few common install locations + if test x"${ac_cv_c_tkconfig}" = x ; then + for i in `ls -d ${libdir} 2>/dev/null` \ + `ls -d ${exec_prefix}/lib 2>/dev/null` \ + `ls -d ${prefix}/lib 2>/dev/null` \ + `ls -d /cygdrive/c/Tcl/lib 2>/dev/null` \ + `ls -d /cygdrive/c/Progra~1/Tcl/lib 2>/dev/null` \ + `ls -d /c/Tcl/lib 2>/dev/null` \ + `ls -d /c/Progra~1/Tcl/lib 2>/dev/null` \ + `ls -d C:/Tcl/lib 2>/dev/null` \ + `ls -d C:/Progra~1/Tcl/lib 2>/dev/null` \ + ; do + if test -f "$i/tkConfig.sh" ; then + ac_cv_c_tkconfig="`(cd $i; pwd)`" + break + fi + done + fi + + # check in a few other private locations + if test x"${ac_cv_c_tkconfig}" = x ; then + for i in \ + ${srcdir}/../tk \ + `ls -dr ${srcdir}/../tk[[8-9]].[[0-9]].[[0-9]]* 2>/dev/null` \ + `ls -dr ${srcdir}/../tk[[8-9]].[[0-9]] 2>/dev/null` \ + `ls -dr ${srcdir}/../tk[[8-9]].[[0-9]]* 2>/dev/null` ; do + if test -f "$i/win/tkConfig.sh" ; then + ac_cv_c_tkconfig="`(cd $i/win; pwd)`" + break + fi + done + fi + ]) + + if test x"${ac_cv_c_tkconfig}" = x ; then + TK_BIN_DIR="# no Tk configs found" + AC_MSG_ERROR([Can't find Tk configuration definitions. Use --with-tk to specify a directory containing tkConfig.sh]) + else + no_tk= + TK_BIN_DIR="${ac_cv_c_tkconfig}" + AC_MSG_RESULT([found ${TK_BIN_DIR}/tkConfig.sh]) + fi + fi +]) + +#------------------------------------------------------------------------ +# SC_LOAD_TCLCONFIG -- +# +# Load the tclConfig.sh file. +# +# Arguments: +# +# Requires the following vars to be set: +# TCL_BIN_DIR +# +# Results: +# +# Substitutes the following vars: +# TCL_BIN_DIR +# TCL_SRC_DIR +# TCL_LIB_FILE +# +#------------------------------------------------------------------------ + +AC_DEFUN([SC_LOAD_TCLCONFIG], [ + AC_MSG_CHECKING([for existence of ${TCL_BIN_DIR}/tclConfig.sh]) + + if test -f "${TCL_BIN_DIR}/tclConfig.sh" ; then + AC_MSG_RESULT([loading]) + . "${TCL_BIN_DIR}/tclConfig.sh" + else + AC_MSG_RESULT([could not find ${TCL_BIN_DIR}/tclConfig.sh]) + fi + + # + # If the TCL_BIN_DIR is the build directory (not the install directory), + # then set the common variable name to the value of the build variables. + # For example, the variable TCL_LIB_SPEC will be set to the value + # of TCL_BUILD_LIB_SPEC. An extension should make use of TCL_LIB_SPEC + # instead of TCL_BUILD_LIB_SPEC since it will work with both an + # installed and uninstalled version of Tcl. + # + + if test -f $TCL_BIN_DIR/Makefile ; then + TCL_LIB_SPEC=${TCL_BUILD_LIB_SPEC} + TCL_STUB_LIB_SPEC=${TCL_BUILD_STUB_LIB_SPEC} + TCL_STUB_LIB_PATH=${TCL_BUILD_STUB_LIB_PATH} + fi + + # + # eval is required to do the TCL_DBGX substitution + # + + eval "TCL_LIB_FILE=\"${TCL_LIB_FILE}\"" + eval "TCL_LIB_FLAG=\"${TCL_LIB_FLAG}\"" + eval "TCL_LIB_SPEC=\"${TCL_LIB_SPEC}\"" + + eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\"" + eval "TCL_STUB_LIB_FLAG=\"${TCL_STUB_LIB_FLAG}\"" + eval "TCL_STUB_LIB_SPEC=\"${TCL_STUB_LIB_SPEC}\"" + + AC_SUBST(TCL_VERSION) + AC_SUBST(TCL_BIN_DIR) + AC_SUBST(TCL_SRC_DIR) + + AC_SUBST(TCL_LIB_FILE) + AC_SUBST(TCL_LIB_FLAG) + AC_SUBST(TCL_LIB_SPEC) + + AC_SUBST(TCL_STUB_LIB_FILE) + AC_SUBST(TCL_STUB_LIB_FLAG) + AC_SUBST(TCL_STUB_LIB_SPEC) + + AC_SUBST(TCL_DEFS) +]) + +#------------------------------------------------------------------------ +# SC_LOAD_TKCONFIG -- +# +# Load the tkConfig.sh file +# +# Arguments: +# +# Requires the following vars to be set: +# TK_BIN_DIR +# +# Results: +# +# Sets the following vars that should be in tkConfig.sh: +# TK_BIN_DIR +#------------------------------------------------------------------------ + +AC_DEFUN([SC_LOAD_TKCONFIG], [ + AC_MSG_CHECKING([for existence of ${TK_BIN_DIR}/tkConfig.sh]) + + if test -f "${TK_BIN_DIR}/tkConfig.sh" ; then + AC_MSG_RESULT([loading]) + . "${TK_BIN_DIR}/tkConfig.sh" + else + AC_MSG_RESULT([could not find ${TK_BIN_DIR}/tkConfig.sh]) + fi + + + AC_SUBST(TK_BIN_DIR) + AC_SUBST(TK_SRC_DIR) + AC_SUBST(TK_LIB_FILE) +]) + +#------------------------------------------------------------------------ +# SC_ENABLE_SHARED -- +# +# Allows the building of shared libraries +# +# Arguments: +# none +# +# Results: +# +# Adds the following arguments to configure: +# --enable-shared=yes|no +# +# Defines the following vars: +# STATIC_BUILD Used for building import/export libraries +# on Windows. +# +# Sets the following vars: +# SHARED_BUILD Value of 1 or 0 +#------------------------------------------------------------------------ + +AC_DEFUN([SC_ENABLE_SHARED], [ + AC_MSG_CHECKING([how to build libraries]) + AC_ARG_ENABLE(shared, + [ --enable-shared build and link with shared libraries (default: on)], + [tcl_ok=$enableval], [tcl_ok=yes]) + + if test "${enable_shared+set}" = set; then + enableval="$enable_shared" + tcl_ok=$enableval + else + tcl_ok=yes + fi + + if test "$tcl_ok" = "yes" ; then + AC_MSG_RESULT([shared]) + SHARED_BUILD=1 + else + AC_MSG_RESULT([static]) + SHARED_BUILD=0 + AC_DEFINE(STATIC_BUILD, 1, [Is this a static build?]) + fi +]) + +#------------------------------------------------------------------------ +# SC_ENABLE_THREADS -- +# +# Specify if thread support should be enabled +# +# Arguments: +# none +# +# Results: +# +# Adds the following arguments to configure: +# --enable-threads=yes|no +# +# Defines the following vars: +# TCL_THREADS +#------------------------------------------------------------------------ + +AC_DEFUN([SC_ENABLE_THREADS], [ + AC_MSG_CHECKING(for building with threads) + AC_ARG_ENABLE(threads, [ --enable-threads build with threads (default: on)], + [tcl_ok=$enableval], [tcl_ok=yes]) + + if test "$tcl_ok" = "yes"; then + AC_MSG_RESULT([yes (default)]) + TCL_THREADS=1 + AC_DEFINE(TCL_THREADS) + # USE_THREAD_ALLOC tells us to try the special thread-based + # allocator that significantly reduces lock contention + AC_DEFINE(USE_THREAD_ALLOC) + else + TCL_THREADS=0 + AC_MSG_RESULT(no) + fi + AC_SUBST(TCL_THREADS) +]) + +#------------------------------------------------------------------------ +# SC_ENABLE_SYMBOLS -- +# +# Specify if debugging symbols should be used. +# Memory (TCL_MEM_DEBUG) and compile (TCL_COMPILE_DEBUG) debugging +# can also be enabled. +# +# Arguments: +# none +# +# Requires the following vars to be set in the Makefile: +# CFLAGS_DEBUG +# CFLAGS_OPTIMIZE +# +# Results: +# +# Adds the following arguments to configure: +# --enable-symbols +# +# Defines the following vars: +# CFLAGS_DEFAULT Sets to $(CFLAGS_DEBUG) if true +# Sets to $(CFLAGS_OPTIMIZE) if false +# LDFLAGS_DEFAULT Sets to $(LDFLAGS_DEBUG) if true +# Sets to $(LDFLAGS_OPTIMIZE) if false +# DBGX Debug library extension +# +#------------------------------------------------------------------------ + +AC_DEFUN([SC_ENABLE_SYMBOLS], [ + AC_MSG_CHECKING([for build with symbols]) + AC_ARG_ENABLE(symbols, [ --enable-symbols build with debugging symbols (default: off)], [tcl_ok=$enableval], [tcl_ok=no]) +# FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT. + if test "$tcl_ok" = "no"; then + CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)' + LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)' + DBGX="" + AC_DEFINE(NDEBUG, 1, [Is no debugging enabled?]) + AC_MSG_RESULT([no]) + + AC_DEFINE(TCL_CFG_OPTIMIZED) + else + CFLAGS_DEFAULT='$(CFLAGS_DEBUG)' + LDFLAGS_DEFAULT='$(LDFLAGS_DEBUG)' + DBGX=g + if test "$tcl_ok" = "yes"; then + AC_MSG_RESULT([yes (standard debugging)]) + fi + fi + AC_SUBST(CFLAGS_DEFAULT) + AC_SUBST(LDFLAGS_DEFAULT) + + if test "$tcl_ok" = "mem" -o "$tcl_ok" = "all"; then + AC_DEFINE(TCL_MEM_DEBUG, 1, [Is memory debugging enabled?]) + fi + + if test "$tcl_ok" = "compile" -o "$tcl_ok" = "all"; then + AC_DEFINE(TCL_COMPILE_DEBUG, 1, [Is bytecode debugging enabled?]) + AC_DEFINE(TCL_COMPILE_STATS, 1, [Are bytecode statistics enabled?]) + fi + + if test "$tcl_ok" != "yes" -a "$tcl_ok" != "no"; then + if test "$tcl_ok" = "all"; then + AC_MSG_RESULT([enabled symbols mem compile debugging]) + else + AC_MSG_RESULT([enabled $tcl_ok debugging]) + fi + fi +]) + +#-------------------------------------------------------------------- +# SC_CONFIG_CFLAGS +# +# Try to determine the proper flags to pass to the compiler +# for building shared libraries and other such nonsense. +# +# NOTE: The backslashes in quotes below are substituted twice +# due to the fact that they are in a macro and then inlined +# in the final configure script. +# +# Arguments: +# none +# +# Results: +# +# Can the following vars: +# EXTRA_CFLAGS +# CFLAGS_DEBUG +# CFLAGS_OPTIMIZE +# CFLAGS_WARNING +# LDFLAGS_DEBUG +# LDFLAGS_OPTIMIZE +# LDFLAGS_CONSOLE +# LDFLAGS_WINDOW +# CC_OBJNAME +# CC_EXENAME +# CYGPATH +# STLIB_LD +# SHLIB_LD +# SHLIB_LD_LIBS +# LIBS +# AR +# RC +# RES +# +# MAKE_LIB +# MAKE_STUB_LIB +# MAKE_EXE +# MAKE_DLL +# +# LIBSUFFIX +# LIBFLAGSUFFIX +# LIBPREFIX +# LIBRARIES +# EXESUFFIX +# DLLSUFFIX +# +#-------------------------------------------------------------------- + +AC_DEFUN([SC_CONFIG_CFLAGS], [ + + # Step 0: Enable 64 bit support? + + AC_MSG_CHECKING([if 64bit support is requested]) + AC_ARG_ENABLE(64bit,[ --enable-64bit enable 64bit support (where applicable)], [do64bit=$enableval], [do64bit=no]) + AC_MSG_RESULT($do64bit) + + # Cross-compiling options for Windows/CE builds + + AC_MSG_CHECKING([if Windows/CE build is requested]) + AC_ARG_ENABLE(wince,[ --enable-wince enable Win/CE support (where applicable)], [doWince=$enableval], [doWince=no]) + AC_MSG_RESULT($doWince) + + AC_MSG_CHECKING([for Windows/CE celib directory]) + AC_ARG_WITH(celib,[ --with-celib=DIR use Windows/CE support library from DIR], + CELIB_DIR=$withval, CELIB_DIR=NO_CELIB) + AC_MSG_RESULT([$CELIB_DIR]) + + # 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) + + SHLIB_SUFFIX=".dll" + + # MACHINE is IX86 for LINK, but this is used by the manifest, + # which requires x86|amd64|ia64. + MACHINE="X86" + + if test "$GCC" = "yes"; then + + AC_CACHE_CHECK(for cross-compile version of gcc, + ac_cv_cross, + AC_TRY_COMPILE([ + #ifndef _WIN32 + #error cross-compiler + #endif + ], [], + ac_cv_cross=no, + ac_cv_cross=yes) + ) + + if test "$ac_cv_cross" = "yes"; then + case "$do64bit" in + amd64|x64|yes) + CC="x86_64-w64-mingw32-gcc" + LD="x86_64-w64-mingw32-ld" + AR="x86_64-w64-mingw32-ar" + RANLIB="x86_64-w64-mingw32-ranlib" + RC="x86_64-w64-mingw32-windres" + ;; + *) + CC="i686-w64-mingw32-gcc" + LD="i686-w64-mingw32-ld" + AR="i686-w64-mingw32-ar" + RANLIB="i686-w64-mingw32-ranlib" + RC="i686-w64-mingw32-windres" + ;; + esac + fi + fi + + # Check for a bug in gcc's windres that causes the + # compile to fail when a Windows native path is + # passed into windres. The mingw toolchain requires + # Windows native paths while Cygwin should work + # with both. Avoid the bug by passing a POSIX + # path when using the Cygwin toolchain. + + if test "$GCC" = "yes" && test "$CYGPATH" != "echo" ; then + conftest=/tmp/conftest.rc + echo "STRINGTABLE BEGIN" > $conftest + echo "101 \"name\"" >> $conftest + echo "END" >> $conftest + + AC_MSG_CHECKING([for Windows native path bug in windres]) + cyg_conftest=`$CYGPATH $conftest` + if AC_TRY_COMMAND($RC -o conftest.res.o $cyg_conftest) ; then + AC_MSG_RESULT([no]) + else + AC_MSG_RESULT([yes]) + CYGPATH=echo + fi + conftest= + cyg_conftest= + fi + + if test "$CYGPATH" = "echo"; then + DEPARG='"$<"' + else + DEPARG='"$(shell $(CYGPATH) $<)"' + fi + + # set various compiler flags depending on whether we are using gcc or cl + + if test "${GCC}" = "yes" ; then + extra_cflags="-pipe" + extra_ldflags="-pipe -static-libgcc" + AC_CACHE_CHECK(for mingw32 version of gcc, + ac_cv_win32, + AC_TRY_COMPILE([ + #ifdef _WIN32 + #error win32 + #endif + ], [], + ac_cv_win32=no, + ac_cv_win32=yes) + ) + if test "$ac_cv_win32" != "yes"; then + AC_MSG_ERROR([${CC} cannot produce win32 executables.]) + fi + + hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -mwindows -municode -Dmain=xxmain" + AC_CACHE_CHECK(for working -municode linker flag, + ac_cv_municode, + AC_TRY_LINK([ + #include <windows.h> + int APIENTRY wWinMain(HINSTANCE a, HINSTANCE b, LPWSTR c, int d) {return 0;} + ], + [], + ac_cv_municode=yes, + ac_cv_municode=no) + ) + CFLAGS=$hold_cflags + if test "$ac_cv_municode" = "yes" ; then + extra_ldflags="$extra_ldflags -municode" + else + extra_cflags="$extra_cflags -DTCL_BROKEN_MAINARGS" + fi + fi + + AC_MSG_CHECKING([compiler flags]) + if test "${GCC}" = "yes" ; then + SHLIB_LD="" + SHLIB_LD_LIBS='${LIBS}' + LIBS="-lnetapi32 -lkernel32 -luser32 -ladvapi32 -luserenv -lws2_32" + # 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' + RC_OUT=-o + RC_TYPE= + RC_INCLUDE=--include + RC_DEFINE=--define + RES=res.o + MAKE_LIB="\${STLIB_LD} \[$]@" + MAKE_STUB_LIB="\${STLIB_LD} \[$]@" + POST_MAKE_LIB="\${RANLIB} \[$]@" + MAKE_EXE="\${CC} -o \[$]@" + LIBPREFIX="lib" + + if test "${SHARED_BUILD}" = "0" ; then + # static + AC_MSG_RESULT([using static flags]) + runtime= + LIBRARIES="\${STATIC_LIBRARIES}" + EXESUFFIX="s\${DBGX}.exe" + else + # dynamic + AC_MSG_RESULT([using shared flags]) + + # ad-hoc check to see if CC supports -shared. + if "${CC}" -shared 2>&1 | egrep ': -shared not supported' >/dev/null; then + AC_MSG_ERROR([${CC} does not support the -shared option. + You will need to upgrade to a newer version of the toolchain.]) + fi + + runtime= + # Add SHLIB_LD_LIBS to the Make rule, not here. + + 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 -Wwrite-strings -Wsign-compare -Wdeclaration-after-statement" + LDFLAGS_DEBUG= + LDFLAGS_OPTIMIZE= + + # Specify the CC output file names based on the target name + CC_OBJNAME="-o \[$]@" + CC_EXENAME="-o \[$]@" + + # Specify linker flags depending on the type of app being + # built -- Console vs. Window. + # + # ORIGINAL COMMENT: + # We need to pass -e _WinMain@16 so that ld will use + # WinMain() instead of main() as the entry point. We can't + # use autoconf to check for this case since it would need + # to run an executable and that does not work when + # cross compiling. Remove this -e workaround once we + # require a gcc that does not have this bug. + # + # MK NOTE: Tk should use a different mechanism. This causes + # interesting problems, such as wish dying at startup. + #LDFLAGS_WINDOW="-mwindows -e _WinMain@16 ${extra_ldflags}" + LDFLAGS_CONSOLE="-mconsole ${extra_ldflags}" + LDFLAGS_WINDOW="-mwindows ${extra_ldflags}" + + case "$do64bit" in + amd64|x64|yes) + MACHINE="AMD64" ; # assume AMD64 as default 64-bit build + AC_MSG_RESULT([ Using 64-bit $MACHINE mode]) + ;; + ia64) + MACHINE="IA64" + AC_MSG_RESULT([ Using 64-bit $MACHINE mode]) + ;; + *) + AC_TRY_COMPILE([ + #ifndef _WIN64 + #error 32-bit + #endif + ], [], + tcl_win_64bit=yes, + tcl_win_64bit=no + ) + if test "$tcl_win_64bit" = "yes" ; then + do64bit=amd64 + MACHINE="AMD64" + AC_MSG_RESULT([ Using 64-bit $MACHINE mode]) + fi + ;; + esac + else + if test "${SHARED_BUILD}" = "0" ; then + # static + AC_MSG_RESULT([using static flags]) + runtime=-MT + LIBRARIES="\${STATIC_LIBRARIES}" + EXESUFFIX="s\${DBGX}.exe" + else + # dynamic + AC_MSG_RESULT([using shared flags]) + runtime=-MD + # Add SHLIB_LD_LIBS to the Make rule, not here. + LIBRARIES="\${SHARED_LIBRARIES}" + EXESUFFIX="\${DBGX}.exe" + case "x`echo \${VisualStudioVersion}`" in + x1[[4-9]]*) + lflags="${lflags} -nodefaultlib:libucrt.lib" + ;; + *) + ;; + 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. + # This magic is based on MS Platform SDK for Win2003 SP1 - hobbs + if test "$do64bit" != "no" ; then + if test "x${MSSDK}x" = "xx" ; then + MSSDK="C:/Progra~1/Microsoft Platform SDK" + fi + MSSDK=`echo "$MSSDK" | sed -e 's!\\\!/!g'` + PATH64="" + case "$do64bit" in + amd64|x64|yes) + MACHINE="AMD64" ; # assume AMD64 as default 64-bit build + PATH64="${MSSDK}/Bin/Win64/x86/AMD64" + ;; + ia64) + MACHINE="IA64" + PATH64="${MSSDK}/Bin/Win64" + ;; + esac + if test ! -d "${PATH64}" ; then + AC_MSG_WARN([Could not find 64-bit $MACHINE SDK]) + fi + AC_MSG_RESULT([ Using 64-bit $MACHINE mode]) + fi + + LIBS="netapi32.lib kernel32.lib user32.lib advapi32.lib userenv.lib ws2_32.lib" + + case "x`echo \${VisualStudioVersion}`" in + x1[[4-9]]*) + LIBS="$LIBS ucrt.lib" + ;; + *) + ;; + esac + + if test "$do64bit" != "no" ; then + # The space-based-path will work for the Makefile, but will + # not work if AC_TRY_COMPILE is called. TEA has the + # TEA_PATH_NOSPACE to avoid this issue. + # Check if _WIN64 is already recognized, and if so we don't + # need to modify CC. + AC_CHECK_DECL([_WIN64], [], + [CC="\"${PATH64}/cl.exe\" -I\"${MSSDK}/Include\" \ + -I\"${MSSDK}/Include/crt\" \ + -I\"${MSSDK}/Include/crt/sys\""]) + RC="\"${MSSDK}/bin/rc.exe\"" + CFLAGS_DEBUG="-nologo -Zi -Od ${runtime}d" + # Do not use -O2 for Win64 - this has proved buggy in code gen. + CFLAGS_OPTIMIZE="-nologo -O1 ${runtime}" + lflags="${lflags} -nologo -MACHINE:${MACHINE} -LIBPATH:\"${MSSDK}/Lib/${MACHINE}\"" + LINKBIN="\"${PATH64}/link.exe\"" + # Avoid 'unresolved external symbol __security_cookie' errors. + # c.f. http://support.microsoft.com/?id=894573 + LIBS="$LIBS bufferoverflowU.lib" + else + RC="rc" + # -Od - no optimization + # -WX - warnings as errors + CFLAGS_DEBUG="-nologo -Z7 -Od -WX ${runtime}d" + # -O2 - create fast code (/Og /Oi /Ot /Oy /Ob2 /Gs /GF /Gy) + CFLAGS_OPTIMIZE="-nologo -O2 ${runtime}" + lflags="${lflags} -nologo" + LINKBIN="link" + fi + + if test "$doWince" != "no" ; then + # Set defaults for common evc4/PPC2003 setup + # Currently Tcl requires 300+, possibly 420+ for sockets + CEVERSION=420; # could be 211 300 301 400 420 ... + TARGETCPU=ARMV4; # could be ARMV4 ARM MIPS SH3 X86 ... + ARCH=ARM; # could be ARM MIPS X86EM ... + PLATFORM="Pocket PC 2003"; # or "Pocket PC 2002" + if test "$doWince" != "yes"; then + # If !yes then the user specified something + # Reset ARCH to allow user to skip specifying it + ARCH= + eval `echo $doWince | awk -F "," '{ \ + if (length([$]1)) { printf "CEVERSION=\"%s\"\n", [$]1; \ + if ([$]1 < 400) { printf "PLATFORM=\"Pocket PC 2002\"\n" } }; \ + if (length([$]2)) { printf "TARGETCPU=\"%s\"\n", toupper([$]2) }; \ + if (length([$]3)) { printf "ARCH=\"%s\"\n", toupper([$]3) }; \ + if (length([$]4)) { printf "PLATFORM=\"%s\"\n", [$]4 }; \ + }'` + if test "x${ARCH}" = "x" ; then + ARCH=$TARGETCPU; + fi + fi + OSVERSION=WCE$CEVERSION; + if test "x${WCEROOT}" = "x" ; then + WCEROOT="C:/Program Files/Microsoft eMbedded C++ 4.0" + if test ! -d "${WCEROOT}" ; then + WCEROOT="C:/Program Files/Microsoft eMbedded Tools" + fi + fi + if test "x${SDKROOT}" = "x" ; then + SDKROOT="C:/Program Files/Windows CE Tools" + if test ! -d "${SDKROOT}" ; then + SDKROOT="C:/Windows CE Tools" + fi + fi + # The space-based-path will work for the Makefile, but will + # not work if AC_TRY_COMPILE is called. + WCEROOT=`echo "$WCEROOT" | sed -e 's!\\\!/!g'` + SDKROOT=`echo "$SDKROOT" | sed -e 's!\\\!/!g'` + CELIB_DIR=`echo "$CELIB_DIR" | sed -e 's!\\\!/!g'` + if test ! -d "${CELIB_DIR}/inc"; then + AC_MSG_ERROR([Invalid celib directory "${CELIB_DIR}"]) + fi + if test ! -d "${SDKROOT}/${OSVERSION}/${PLATFORM}/Lib/${TARGETCPU}"\ + -o ! -d "${WCEROOT}/EVC/${OSVERSION}/bin"; then + AC_MSG_ERROR([could not find PocketPC SDK or target compiler to enable WinCE mode [$CEVERSION,$TARGETCPU,$ARCH,$PLATFORM]]) + else + CEINCLUDE="${SDKROOT}/${OSVERSION}/${PLATFORM}/include" + if test -d "${CEINCLUDE}/${TARGETCPU}" ; then + CEINCLUDE="${CEINCLUDE}/${TARGETCPU}" + fi + CELIBPATH="${SDKROOT}/${OSVERSION}/${PLATFORM}/Lib/${TARGETCPU}" + fi + fi + + if test "$doWince" != "no" ; then + CEBINROOT="${WCEROOT}/EVC/${OSVERSION}/bin" + if test "${TARGETCPU}" = "X86"; then + CC="${CEBINROOT}/cl.exe" + else + CC="${CEBINROOT}/cl${ARCH}.exe" + fi + CC="\"${CC}\" -I\"${CELIB_DIR}/inc\" -I\"${CEINCLUDE}\"" + RC="\"${WCEROOT}/Common/EVC/bin/rc.exe\"" + arch=`echo ${ARCH} | awk '{print tolower([$]0)}'` + defs="${ARCH} _${ARCH}_ ${arch} PALM_SIZE _MT _DLL _WINDOWS" + for i in $defs ; do + AC_DEFINE_UNQUOTED($i) + done +# if test "${ARCH}" = "X86EM"; then +# AC_DEFINE_UNQUOTED(_WIN32_WCE_EMULATION) +# fi + AC_DEFINE_UNQUOTED(_WIN32_WCE, $CEVERSION) + AC_DEFINE_UNQUOTED(UNDER_CE, $CEVERSION) + CFLAGS_DEBUG="-nologo -Zi -Od" + CFLAGS_OPTIMIZE="-nologo -O2" + lversion=`echo ${CEVERSION} | sed -e 's/\(.\)\(..\)/\1\.\2/'` + lflags="-nodefaultlib -MACHINE:${ARCH} -LIBPATH:\"${CELIBPATH}\" -subsystem:windowsce,${lversion} -nologo" + LINKBIN="\"${CEBINROOT}/link.exe\"" + AC_SUBST(CELIB_DIR) + if test "${CEVERSION}" -lt 400 ; then + LIBS="coredll.lib corelibc.lib winsock.lib" + else + LIBS="coredll.lib corelibc.lib ws2.lib" + fi + # celib currently stuck at wce300 status + #LIBS="$LIBS \${CELIB_DIR}/wince-${ARCH}-pocket-${OSVERSION}-release/celib.lib" + LIBS="$LIBS \"\${CELIB_DIR}/wince-${ARCH}-pocket-wce300-release/celib.lib\"" + LIBS_GUI="commctrl.lib commdlg.lib" + else + LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib uuid.lib" + 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 + RC_TYPE=-r + RC_INCLUDE=-i + RC_DEFINE=-d + RES=res + MAKE_LIB="\${STLIB_LD} -out:\[$]@" + MAKE_STUB_LIB="\${STLIB_LD} -nodefaultlib -out:\[$]@" + POST_MAKE_LIB= + MAKE_EXE="\${CC} -Fe\[$]@" + LIBPREFIX="" + + CFLAGS_DEBUG="${CFLAGS_DEBUG} -D_CRT_SECURE_NO_DEPRECATE -D_CRT_NONSTDC_NO_DEPRECATE" + CFLAGS_OPTIMIZE="${CFLAGS_OPTIMIZE} -D_CRT_SECURE_NO_DEPRECATE -D_CRT_NONSTDC_NO_DEPRECATE" + + EXTRA_CFLAGS="" + CFLAGS_WARNING="-W3" + LDFLAGS_DEBUG="-debug" + LDFLAGS_OPTIMIZE="-release" + + # Specify the CC output file names based on the target name + CC_OBJNAME="-Fo\[$]@" + CC_EXENAME="-Fe\"\$(shell \$(CYGPATH) '\[$]@')\"" + + # Specify linker flags depending on the type of app being + # built -- Console vs. Window. + if test "$doWince" != "no" -a "${TARGETCPU}" != "X86"; then + LDFLAGS_CONSOLE="-link ${lflags}" + LDFLAGS_WINDOW=${LDFLAGS_CONSOLE} + else + LDFLAGS_CONSOLE="-link -subsystem:console ${lflags}" + LDFLAGS_WINDOW="-link -subsystem:windows ${lflags}" + fi + fi + + if test "$do64bit" != "no" ; then + AC_DEFINE(TCL_CFG_DO64BIT) + fi + + if test "${GCC}" = "yes" ; then + AC_CACHE_CHECK(for SEH support in compiler, + tcl_cv_seh, + AC_TRY_RUN([ + #define WIN32_LEAN_AND_MEAN + #include <windows.h> + #undef WIN32_LEAN_AND_MEAN + + int main(int argc, char** argv) { + int a, b = 0; + __try { + a = 666 / b; + } + __except (EXCEPTION_EXECUTE_HANDLER) { + return 0; + } + return 1; + } + ], + tcl_cv_seh=yes, + tcl_cv_seh=no, + tcl_cv_seh=no) + ) + if test "$tcl_cv_seh" = "no" ; then + AC_DEFINE(HAVE_NO_SEH, 1, + [Defined when mingw does not support SEH]) + fi + + # + # Check to see if the excpt.h include file provided contains the + # definition for EXCEPTION_DISPOSITION; if not, which is the case + # with Cygwin's version as of 2002-04-10, define it to be int, + # sufficient for getting the current code to work. + # + AC_CACHE_CHECK(for EXCEPTION_DISPOSITION support in include files, + tcl_cv_eh_disposition, + AC_TRY_COMPILE([ +# define WIN32_LEAN_AND_MEAN +# include <windows.h> +# undef WIN32_LEAN_AND_MEAN + ],[ + EXCEPTION_DISPOSITION x; + ], + tcl_cv_eh_disposition=yes, + tcl_cv_eh_disposition=no) + ) + if test "$tcl_cv_eh_disposition" = "no" ; then + AC_DEFINE(EXCEPTION_DISPOSITION, int, + [Defined when cygwin/mingw does not support EXCEPTION DISPOSITION]) + fi + + # Check to see if winnt.h defines CHAR, SHORT, and LONG + # even if VOID has already been #defined. The win32api + # used by mingw and cygwin is known to do this. + + AC_CACHE_CHECK(for winnt.h that ignores VOID define, + tcl_cv_winnt_ignore_void, + AC_TRY_COMPILE([ + #define VOID void + #define WIN32_LEAN_AND_MEAN + #include <windows.h> + #undef WIN32_LEAN_AND_MEAN + ], [ + CHAR c; + SHORT s; + LONG l; + ], + tcl_cv_winnt_ignore_void=yes, + tcl_cv_winnt_ignore_void=no) + ) + if test "$tcl_cv_winnt_ignore_void" = "yes" ; then + AC_DEFINE(HAVE_WINNT_IGNORE_VOID, 1, + [Defined when cygwin/mingw ignores VOID define in winnt.h]) + fi + + # See if the compiler supports casting to a union type. + # This is used to stop gcc from printing a compiler + # warning when initializing a union member. + + AC_CACHE_CHECK(for cast to union support, + tcl_cv_cast_to_union, + AC_TRY_COMPILE([], + [ + union foo { int i; double d; }; + union foo f = (union foo) (int) 0; + ], + tcl_cv_cast_to_union=yes, + tcl_cv_cast_to_union=no) + ) + if test "$tcl_cv_cast_to_union" = "yes"; then + AC_DEFINE(HAVE_CAST_TO_UNION, 1, + [Defined when compiler supports casting to union type.]) + fi + fi + + # DL_LIBS is empty, but then we match the Unix version + AC_SUBST(DL_LIBS) + AC_SUBST(CFLAGS_DEBUG) + AC_SUBST(CFLAGS_OPTIMIZE) + AC_SUBST(CFLAGS_WARNING) +]) + +#------------------------------------------------------------------------ +# SC_WITH_TCL -- +# +# Location of the Tcl build directory. +# +# Arguments: +# none +# +# Results: +# +# Adds the following arguments to configure: +# --with-tcl=... +# +# Defines the following vars: +# TCL_BIN_DIR Full path to the tcl build dir. +#------------------------------------------------------------------------ + +AC_DEFUN([SC_WITH_TCL], [ + if test -d ../../tcl8.7$1/win; then + TCL_BIN_DEFAULT=../../tcl8.7$1/win + else + TCL_BIN_DEFAULT=../../tcl8.7/win + fi + + AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl 8.7 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) + fi + if test ! -f $TCL_BIN_DIR/Makefile; then + AC_MSG_ERROR(There is no Makefile in $TCL_BIN_DIR: perhaps you did not specify the Tcl *build* directory (not the toplevel Tcl directory) or you forgot to configure Tcl?) + else + echo "building against Tcl binaries in: $TCL_BIN_DIR" + fi + AC_SUBST(TCL_BIN_DIR) +]) + +#------------------------------------------------------------------------ +# SC_PROG_TCLSH +# Locate a tclsh shell installed on the system path. This macro +# will only find a Tcl shell that already exists on the system. +# It will not find a Tcl shell in the Tcl build directory or +# a Tcl shell that has been installed from the Tcl build directory. +# If a Tcl shell can't be located on the PATH, then TCLSH_PROG will +# be set to "". Extensions should take care not to create Makefile +# rules that are run by default and depend on TCLSH_PROG. An +# extension can't assume that an executable Tcl shell exists at +# build time. +# +# Arguments +# none +# +# Results +# Subst's the following values: +# TCLSH_PROG +#------------------------------------------------------------------------ + +AC_DEFUN([SC_PROG_TCLSH], [ + AC_MSG_CHECKING([for tclsh]) + + AC_CACHE_VAL(ac_cv_path_tclsh, [ + search_path=`echo ${PATH} | sed -e 's/:/ /g'` + for dir in $search_path ; do + for j in `ls -r $dir/tclsh[[8-9]]*.exe 2> /dev/null` \ + `ls -r $dir/tclsh* 2> /dev/null` ; do + if test x"$ac_cv_path_tclsh" = x ; then + if test -f "$j" ; then + ac_cv_path_tclsh=$j + break + fi + fi + done + done + ]) + + if test -f "$ac_cv_path_tclsh" ; then + TCLSH_PROG="$ac_cv_path_tclsh" + AC_MSG_RESULT($TCLSH_PROG) + else + # It is not an error if an installed version of Tcl can't be located. + TCLSH_PROG="" + AC_MSG_RESULT([No tclsh found on PATH]) + fi + AC_SUBST(TCLSH_PROG) +]) + +#------------------------------------------------------------------------ +# SC_BUILD_TCLSH +# Determine the fully qualified path name of the tclsh executable +# in the Tcl build directory. This macro will correctly determine +# the name of the tclsh executable even if tclsh has not yet +# been built in the build directory. The build tclsh must be used +# when running tests from an extension build directory. It is not +# correct to use the TCLSH_PROG in cases like this. +# +# Arguments +# none +# +# Results +# Subst's the following values: +# BUILD_TCLSH +#------------------------------------------------------------------------ + +AC_DEFUN([SC_BUILD_TCLSH], [ + AC_MSG_CHECKING([for tclsh in Tcl build directory]) + BUILD_TCLSH=${TCL_BIN_DIR}/tclsh${TCL_MAJOR_VERSION}${TCL_MINOR_VERSION}${TCL_DBGX}${EXEEXT} + AC_MSG_RESULT($BUILD_TCLSH) + AC_SUBST(BUILD_TCLSH) +]) + +#-------------------------------------------------------------------- +# SC_TCL_CFG_ENCODING TIP #59 +# +# Declare the encoding to use for embedded configuration information. +# +# Arguments: +# None. +# +# Results: +# Might append to the following vars: +# DEFS (implicit) +# +# Will define the following vars: +# TCL_CFGVAL_ENCODING +# +#-------------------------------------------------------------------- + +AC_DEFUN([SC_TCL_CFG_ENCODING], [ + AC_ARG_WITH(encoding, [ --with-encoding encoding for configuration values], with_tcencoding=${withval}) + + if test x"${with_tcencoding}" != x ; then + AC_DEFINE_UNQUOTED(TCL_CFGVAL_ENCODING,"${with_tcencoding}") + else + # Default encoding on windows is not "iso8859-1" + AC_DEFINE(TCL_CFGVAL_ENCODING,"cp1252") + fi +]) + +#-------------------------------------------------------------------- +# SC_EMBED_MANIFEST +# +# Figure out if we can embed the manifest where necessary +# +# Arguments: +# An optional manifest to merge into DLL/EXE. +# +# Results: +# Will define the following vars: +# VC_MANIFEST_EMBED_DLL +# VC_MANIFEST_EMBED_EXE +# +#-------------------------------------------------------------------- + +AC_DEFUN([SC_EMBED_MANIFEST], [ + AC_MSG_CHECKING(whether to embed manifest) + AC_ARG_ENABLE(embedded-manifest, + AC_HELP_STRING([--enable-embedded-manifest], + [embed manifest if possible (default: yes)]), + [embed_ok=$enableval], [embed_ok=yes]) + + VC_MANIFEST_EMBED_DLL= + VC_MANIFEST_EMBED_EXE= + result=no + if test "$embed_ok" = "yes" -a "${SHARED_BUILD}" = "1" \ + -a "$GCC" != "yes" ; then + # Add the magic to embed the manifest into the dll/exe + AC_EGREP_CPP([manifest needed], [ +#if defined(_MSC_VER) && _MSC_VER >= 1400 +print("manifest needed") +#endif + ], [ + # Could do a CHECK_PROG for mt, but should always be with MSVC8+ + # Could add 'if test -f' check, but manifest should be created + # in this compiler case + # Add in a manifest argument that may be specified + # XXX Needs improvement so that the test for existence accounts + # XXX for a provided (known) manifest + VC_MANIFEST_EMBED_DLL="if test -f \[$]@.manifest ; then mt.exe -nologo -manifest \[$]@.manifest $1 -outputresource:\[$]@\;2 ; fi" + VC_MANIFEST_EMBED_EXE="if test -f \[$]@.manifest ; then mt.exe -nologo -manifest \[$]@.manifest $1 -outputresource:\[$]@\;1 ; fi" + result=yes + if test "x$1" != x ; then + result="yes ($1)" + fi + ]) + fi + AC_MSG_RESULT([$result]) + AC_SUBST(VC_MANIFEST_EMBED_DLL) + AC_SUBST(VC_MANIFEST_EMBED_EXE) +]) diff --git a/win/tcl.rc b/win/tcl.rc new file mode 100644 index 0000000..be5e0a7 --- /dev/null +++ b/win/tcl.rc @@ -0,0 +1,57 @@ +// Version Resource Script +// + +#include <winver.h> +#include <tcl.h> + +// +// build-up the name suffix that defines the type of build this is. +// +#if TCL_THREADS +#define SUFFIX_THREADS "t" +#else +#define SUFFIX_THREADS "" +#endif + +#if DEBUG && !UNCHECKED +#define SUFFIX_DEBUG "g" +#else +#define SUFFIX_DEBUG "" +#endif + +#define SUFFIX SUFFIX_THREADS SUFFIX_DEBUG + + +LANGUAGE 0x9, 0x1 /* LANG_ENGLISH, SUBLANG_DEFAULT */ + +VS_VERSION_INFO VERSIONINFO + FILEVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL + PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL + FILEFLAGSMASK 0x3fL +#ifdef DEBUG + FILEFLAGS VS_FF_DEBUG +#else + FILEFLAGS 0x0L +#endif + FILEOS VOS__WINDOWS32 + FILETYPE VFT_DLL + FILESUBTYPE 0x0L +BEGIN + BLOCK "StringFileInfo" + BEGIN + BLOCK "040904b0" /* LANG_ENGLISH/SUBLANG_ENGLISH_US, Unicode CP */ + BEGIN + VALUE "FileDescription", "Tcl DLL\0" + VALUE "OriginalFilename", "tcl" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) SUFFIX ".dll\0" + VALUE "CompanyName", "ActiveState Corporation\0" + VALUE "FileVersion", TCL_PATCH_LEVEL + VALUE "LegalCopyright", "Copyright \251 2001 by ActiveState Corporation, et al\0" + VALUE "ProductName", "Tcl " TCL_VERSION " for Windows\0" + VALUE "ProductVersion", TCL_PATCH_LEVEL + END + END + BLOCK "VarFileInfo" + BEGIN + VALUE "Translation", 0x409, 1200 + END +END diff --git a/win/tclAppInit.c b/win/tclAppInit.c new file mode 100644 index 0000000..ef9f98b --- /dev/null +++ b/win/tclAppInit.c @@ -0,0 +1,338 @@ +/* + * tclAppInit.c -- + * + * Provides a default version of the main program and Tcl_AppInit + * procedure for tclsh and other Tcl-based applications (without Tk). + * Note that this program must be built in Win32 console mode to work + * properly. + * + * 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 Tcltest_Init; +extern Tcl_PackageInitProc 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; +#endif + +#ifdef TCL_BROKEN_MAINARGS +int _CRT_glob = 0; +static void setargv(int *argcPtr, TCHAR ***argvPtr); +#endif /* TCL_BROKEN_MAINARGS */ + +/* + * The following #if block allows you to change the AppInit function by using + * a #define of TCL_LOCAL_APPINIT instead of rewriting this entire file. The + * #if checks for that #define and uses Tcl_AppInit if it does not exist. + */ + +#ifndef TCL_LOCAL_APPINIT +#define TCL_LOCAL_APPINIT Tcl_AppInit +#endif +#ifndef MODULE_SCOPE +# define MODULE_SCOPE extern +#endif +MODULE_SCOPE int TCL_LOCAL_APPINIT(Tcl_Interp *); + +/* + * The following #if block allows you to change how Tcl finds the startup + * script, prime the library or encoding paths, fiddle with the argv, etc., + * without needing to rewrite Tcl_Main() + */ + +#ifdef TCL_LOCAL_MAIN_HOOK +MODULE_SCOPE int TCL_LOCAL_MAIN_HOOK(int *argc, TCHAR ***argv); +#endif + +/* + *---------------------------------------------------------------------- + * + * main -- + * + * This is the main program for the application. + * + * Results: + * None: Tcl_Main never returns here, so this procedure never returns + * either. + * + * Side effects: + * Just about anything, since from here we call arbitrary Tcl code. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_BROKEN_MAINARGS +int +main( + int argc, /* Number of command-line arguments. */ + char *dummy[]) /* Not used. */ +{ + TCHAR **argv; +#else +int +_tmain( + int argc, /* Number of command-line arguments. */ + TCHAR *argv[]) /* Values of command-line arguments. */ +{ +#endif + TCHAR *p; + + /* + * Set up the default locale to be standard "C" locale so parsing is + * performed correctly. + */ + + setlocale(LC_ALL, "C"); + +#ifdef TCL_BROKEN_MAINARGS + /* + * Get our args from the c-runtime. Ignore command line. + */ + + setargv(&argc, &argv); +#endif + + /* + * Forward slashes substituted for backslashes. + */ + + for (p = argv[0]; *p != '\0'; p++) { + if (*p == '\\') { + *p = '/'; + } + } + +#ifdef TCL_LOCAL_MAIN_HOOK + TCL_LOCAL_MAIN_HOOK(&argc, &argv); +#endif + + Tcl_Main(argc, argv, TCL_LOCAL_APPINIT); + return 0; /* Needed only to prevent compiler warning. */ +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppInit -- + * + * This procedure performs application-specific initialization. Most + * applications, especially those that incorporate additional packages, + * will have their own version of this procedure. + * + * Results: + * Returns a standard Tcl completion code, and leaves an error message in + * the interp's result if an error occurs. + * + * Side effects: + * Depends on the startup script. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_AppInit( + Tcl_Interp *interp) /* Interpreter for application. */ +{ + if ((Tcl_Init)(interp) == TCL_ERROR) { + return TCL_ERROR; + } + +#if defined(STATIC_BUILD) && TCL_USE_STATIC_PACKAGES + 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 + +#ifdef TCL_TEST + if (Tcltest_Init(interp) == TCL_ERROR) { + return TCL_ERROR; + } + Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init, Tcltest_SafeInit); +#endif /* TCL_TEST */ + + /* + * 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. (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 procedures called above. + */ + + /* + * Specify a user-specific startup file to invoke if the application is + * run interactively. Typically the startup file is "~/.apprc" where "app" + * is the name of the application. If this line is deleted then no + * user-specific startup file will be run under any conditions. + */ + + (Tcl_ObjSetVar2)(interp, Tcl_NewStringObj("tcl_rcFileName", -1), NULL, + Tcl_NewStringObj("~/tclshrc.tcl", -1), TCL_GLOBAL_ONLY); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * setargv -- + * + * Parse the Windows command line string into argc/argv. Done here + * because we don't trust the builtin argument parser in crt0. Windows + * applications are responsible for breaking their command line into + * arguments. + * + * 2N backslashes + quote -> N backslashes + begin quoted string + * 2N + 1 backslashes + quote -> literal + * N backslashes + non-quote -> literal + * quote + quote in a quoted string -> single quote + * quote + quote not in quoted string -> empty string + * quote -> begin quoted string + * + * Results: + * Fills argcPtr with the number of arguments and argvPtr with the array + * of arguments. + * + * Side effects: + * Memory allocated. + * + *-------------------------------------------------------------------------- + */ + +#ifdef TCL_BROKEN_MAINARGS +static void +setargv( + int *argcPtr, /* Filled with number of argument strings. */ + TCHAR ***argvPtr) /* Filled with argument strings (malloc'd). */ +{ + TCHAR *cmdLine, *p, *arg, *argSpace; + TCHAR **argv; + int argc, size, inquote, copy, slashes; + + cmdLine = GetCommandLine(); + + /* + * Precompute an overly pessimistic guess at the number of arguments in + * the command line by counting non-space spans. + */ + + size = 2; + for (p = cmdLine; *p != '\0'; p++) { + if ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */ + size++; + while ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */ + p++; + } + if (*p == '\0') { + break; + } + } + } + + /* 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; + for (argc = 0; argc < size; argc++) { + argv[argc] = arg = argSpace; + while ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */ + p++; + } + if (*p == '\0') { + break; + } + + inquote = 0; + slashes = 0; + while (1) { + copy = 1; + while (*p == '\\') { + slashes++; + p++; + } + if (*p == '"') { + if ((slashes & 1) == 0) { + copy = 0; + if ((inquote) && (p[1] == '"')) { + p++; + copy = 1; + } else { + inquote = !inquote; + } + } + slashes >>= 1; + } + + while (slashes) { + *arg = '\\'; + arg++; + slashes--; + } + + if ((*p == '\0') || (!inquote && + ((*p == ' ') || (*p == '\t')))) { /* INTL: ISO space. */ + break; + } + if (copy != 0) { + *arg = *p; + arg++; + } + p++; + } + *arg = '\0'; + argSpace = arg + 1; + } + argv[argc] = NULL; + + *argcPtr = argc; + *argvPtr = argv; +} +#endif /* TCL_BROKEN_MAINARGS */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/win/tclConfig.sh.in b/win/tclConfig.sh.in new file mode 100644 index 0000000..97670aa --- /dev/null +++ b/win/tclConfig.sh.in @@ -0,0 +1,181 @@ +# tclConfig.sh -- +# +# This shell script (for sh) is generated automatically by Tcl's +# configure script. It will create shell variables for most of +# the configuration options discovered by the configure script. +# This script is intended to be included by the configure scripts +# for Tcl 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. + +TCL_DLL_FILE="@TCL_DLL_FILE@" + +# Tcl's version number. +TCL_VERSION='@TCL_VERSION@' +TCL_MAJOR_VERSION='@TCL_MAJOR_VERSION@' +TCL_MINOR_VERSION='@TCL_MINOR_VERSION@' +TCL_PATCH_LEVEL='@TCL_PATCH_LEVEL@' + +# C compiler to use for compilation. +TCL_CC='@CC@' + +# -D flags for use with the C compiler. +TCL_DEFS='@DEFS@' + +# If TCL was built with debugging symbols, generated libraries contain +# this string at the end of the library name (before the extension). +TCL_DBGX=@TCL_DBGX@ + +# Default flags used in an optimized and debuggable build, respectively. +TCL_CFLAGS_DEBUG='@CFLAGS_DEBUG@' +TCL_CFLAGS_OPTIMIZE='@CFLAGS_OPTIMIZE@' + +# Default linker flags used in an optimized and debuggable build, respectively. +TCL_LDFLAGS_DEBUG='@LDFLAGS_DEBUG@' +TCL_LDFLAGS_OPTIMIZE='@LDFLAGS_OPTIMIZE@' + +# Flag, 1: we built a shared lib, 0 we didn't +TCL_SHARED_BUILD=@TCL_SHARED_BUILD@ + +# The name of the Tcl library (may be either a .a file or a shared library): +TCL_LIB_FILE='@TCL_LIB_FILE@' + +# Flag to indicate whether shared libraries need export files. +TCL_NEEDS_EXP_FILE=@TCL_NEEDS_EXP_FILE@ + +# String that can be evaluated to generate the part of the export file +# name that comes after the "libxxx" (includes version number, if any, +# extension, and anything else needed). May depend on the variables +# VERSION. On most UNIX systems this is ${VERSION}.exp. +TCL_EXPORT_FILE_SUFFIX='@CFG_TCL_EXPORT_FILE_SUFFIX@' + +# Additional libraries to use when linking Tcl. +TCL_LIBS='@LIBS@' + +# Top-level directory in which Tcl's platform-independent files are +# installed. +TCL_PREFIX='@prefix@' + +# Top-level directory in which Tcl's platform-specific files (e.g. +# executables) are installed. +TCL_EXEC_PREFIX='@exec_prefix@' + +# Flags to pass to cc when compiling the components of a shared library: +TCL_SHLIB_CFLAGS='@SHLIB_CFLAGS@' + +# Flags to pass to cc to get warning messages +TCL_CFLAGS_WARNING='@CFLAGS_WARNING@' + +# Extra flags to pass to cc: +TCL_EXTRA_CFLAGS='@EXTRA_CFLAGS@' + +# Base command to use for combining object files into a shared library: +TCL_SHLIB_LD='@SHLIB_LD@' + +# Base command to use for combining object files into a static library: +TCL_STLIB_LD='@STLIB_LD@' + +# Either '$LIBS' (if dependent libraries should be included when linking +# shared libraries) or an empty string. See Tcl's configure.ac for more +# explanation. +TCL_SHLIB_LD_LIBS='@SHLIB_LD_LIBS@' + +# Suffix to use for the name of a shared library. +TCL_SHLIB_SUFFIX='@SHLIB_SUFFIX@' + +# Library file(s) to include in tclsh and other base applications +# in order to provide facilities needed by DLOBJ above. +TCL_DL_LIBS='@DL_LIBS@' + +# Flags to pass to the compiler when linking object files into +# an executable tclsh or tcltest binary. +TCL_LD_FLAGS='@LDFLAGS@' + +# 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 +# with standard facilities from ANSI C or POSIX. +TCL_COMPAT_OBJS='@LIBOBJS@' + +# Name of the ranlib program to use. +TCL_RANLIB='@RANLIB@' + +# -l flag to pass to the linker to pick up the Tcl library +TCL_LIB_FLAG='@TCL_LIB_FLAG@' + +# String to pass to linker to pick up the Tcl library from its +# build directory. +TCL_BUILD_LIB_SPEC='@TCL_BUILD_LIB_SPEC@' + +# String to pass to linker to pick up the Tcl library from its +# installed directory. +TCL_LIB_SPEC='@TCL_LIB_SPEC@' + +# String to pass to the compiler so that an extension can +# find installed Tcl headers. +TCL_INCLUDE_SPEC='@TCL_INCLUDE_SPEC@' + +# Indicates whether a version numbers should be used in -l switches +# ("ok" means it's safe to use switches like -ltcl7.5; "nodots" means +# use switches like -ltcl75). SunOS and FreeBSD require "nodots", for +# example. +TCL_LIB_VERSIONS_OK='@TCL_LIB_VERSIONS_OK@' + +# String that can be evaluated to generate the part of a shared library +# name that comes after the "libxxx" (includes version number, if any, +# extension, and anything else needed). May depend on the variables +# VERSION and SHLIB_SUFFIX. On most UNIX systems this is +# ${VERSION}${SHLIB_SUFFIX}. +TCL_SHARED_LIB_SUFFIX='@CFG_TCL_SHARED_LIB_SUFFIX@' + +# String that can be evaluated to generate the part of an unshared library +# name that comes after the "libxxx" (includes version number, if any, +# extension, and anything else needed). May depend on the variable +# VERSION. On most UNIX systems this is ${VERSION}.a. +TCL_UNSHARED_LIB_SUFFIX='@CFG_TCL_UNSHARED_LIB_SUFFIX@' + +# Location of the top-level source directory from which Tcl was built. +# This is the directory that contains a README file as well as +# subdirectories such as generic, unix, etc. If Tcl was compiled in a +# different place than the directory containing the source files, this +# points to the location of the sources, not the location where Tcl was +# compiled. +TCL_SRC_DIR='@TCL_SRC_DIR@' + +# List of standard directories in which to look for packages during +# "package require" commands. Contains the "prefix" directory plus also +# the "exec_prefix" directory, if it is different. +TCL_PACKAGE_PATH='@TCL_PACKAGE_PATH@' + +# Tcl supports stub. +TCL_SUPPORTS_STUBS=1 + +# The name of the Tcl stub library (.a): +TCL_STUB_LIB_FILE='@TCL_STUB_LIB_FILE@' + +# -l flag to pass to the linker to pick up the Tcl stub library +TCL_STUB_LIB_FLAG='@TCL_STUB_LIB_FLAG@' + +# String to pass to linker to pick up the Tcl stub library from its +# build directory. +TCL_BUILD_STUB_LIB_SPEC='@TCL_BUILD_STUB_LIB_SPEC@' + +# String to pass to linker to pick up the Tcl stub library from its +# installed directory. +TCL_STUB_LIB_SPEC='@TCL_STUB_LIB_SPEC@' + +# Path to the Tcl stub library in the build directory. +TCL_BUILD_STUB_LIB_PATH='@TCL_BUILD_STUB_LIB_PATH@' + +# Path to the Tcl stub library in the install directory. +TCL_STUB_LIB_PATH='@TCL_STUB_LIB_PATH@' + +# Flag, 1: we built Tcl with threads enabled, 0 we didn't +TCL_THREADS=@TCL_THREADS@ + diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c new file mode 100644 index 0000000..1d6cb2b --- /dev/null +++ b/win/tclWin32Dll.c @@ -0,0 +1,801 @@ +/* + * tclWin32Dll.c -- + * + * This file contains the DLL entry point and other low-level bit bashing + * code that needs inline assembly. + * + * Copyright (c) 1995-1996 Sun Microsystems, Inc. + * Copyright (c) 1998-2000 Scriptics Corporation. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tclWinInt.h" +#if defined(HAVE_INTRIN_H) +# include <intrin.h> +#endif + +/* + * The following variables keep track of information about this DLL on a + * per-instance basis. Each time this DLL is loaded, it gets its own new data + * segment with its own copy of all static and global information. + */ + +static HINSTANCE hInstance; /* HINSTANCE of this DLL. */ +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) && defined (_M_IX86) +#define cpuid __asm __emit 0fh __asm __emit 0a2h +#endif + +static Tcl_Encoding winTCharEncoding = NULL; + +/* + * The following declaration is for the VC++ DLL entry point. + */ + +BOOL APIENTRY DllMain(HINSTANCE hInst, DWORD reason, + LPVOID reserved); + +/* + * The following structure and linked list is to allow us to map between + * volume mount points and drive letters on the fly (no Win API exists for + * this). + */ + +typedef struct MountPointMap { + 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 + * NULL. */ +} MountPointMap; + +/* + * This is the head of the linked list, which is protected by the mutex which + * follows, for thread-enabled builds. + */ + +MountPointMap *driveLetterLookup = NULL; +TCL_DECLARE_MUTEX(mountPointMap) + +/* + * We will need this below. + */ + +#ifdef _WIN32 +#ifndef STATIC_BUILD + +/* + *---------------------------------------------------------------------- + * + * DllEntryPoint -- + * + * This wrapper function is used by Borland to invoke the initialization + * code for Tcl. It simply calls the DllMain routine. + * + * Results: + * See DllMain. + * + * Side effects: + * See DllMain. + * + *---------------------------------------------------------------------- + */ + +BOOL APIENTRY +DllEntryPoint( + HINSTANCE hInst, /* Library instance handle. */ + DWORD reason, /* Reason this function is being called. */ + LPVOID reserved) /* Not used. */ +{ + return DllMain(hInst, reason, reserved); +} + +/* + *---------------------------------------------------------------------- + * + * DllMain -- + * + * This routine is called by the VC++ C run time library init code, or + * the DllEntryPoint routine. It is responsible for initializing various + * dynamically loaded libraries. + * + * Results: + * TRUE on sucess, FALSE on failure. + * + * Side effects: + * Initializes most rudimentary Windows bits. + * + *---------------------------------------------------------------------- + */ + +BOOL APIENTRY +DllMain( + HINSTANCE hInst, /* Library instance handle. */ + DWORD reason, /* Reason this function is being called. */ + LPVOID reserved) /* Not used. */ +{ + switch (reason) { + case DLL_PROCESS_ATTACH: + DisableThreadLibraryCalls(hInst); + TclWinInit(hInst); + return TRUE; + + /* + * DLL_PROCESS_DETACH is unnecessary as the user should call + * Tcl_Finalize explicitly before unloading Tcl. + */ + } + + return TRUE; +} +#endif /* !STATIC_BUILD */ +#endif /* _WIN32 */ + +/* + *---------------------------------------------------------------------- + * + * TclWinGetTclInstance -- + * + * Retrieves the global library instance handle. + * + * Results: + * Returns the global library instance handle. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +HINSTANCE +TclWinGetTclInstance(void) +{ + return hInstance; +} + +/* + *---------------------------------------------------------------------- + * + * TclWinInit -- + * + * This function initializes the internal state of the tcl library. + * + * Results: + * None. + * + * Side effects: + * Initializes the tclPlatformId variable. + * + *---------------------------------------------------------------------- + */ + +void +TclWinInit( + HINSTANCE hInst) /* Library instance handle. */ +{ + OSVERSIONINFOW os; + + hInstance = hInst; + os.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); + GetVersionExW(&os); + platformId = os.dwPlatformId; + + /* + * We no longer support Win32s or Win9x, so just in case someone manages + * to get a runtime there, make sure they know that. + */ + + if (platformId == VER_PLATFORM_WIN32s) { + Tcl_Panic("Win32s is not a supported platform"); + } + if (platformId == VER_PLATFORM_WIN32_WINDOWS) { + Tcl_Panic("Windows 9x is not a supported platform"); + } + + TclWinResetInterfaces(); +} + +/* + *---------------------------------------------------------------------- + * + * TclWinGetPlatformId -- + * + * Determines whether running under NT, 95, or Win32s, to allow runtime + * conditional code. + * + * Results: + * The return value is one of: + * VER_PLATFORM_WIN32s Win32s on Windows 3.1 (not supported) + * VER_PLATFORM_WIN32_WINDOWS Win32 on Windows 95, 98, ME (not supported) + * VER_PLATFORM_WIN32_NT Win32 on Windows NT, 2000, XP + * VER_PLATFORM_WIN32_CE Win32 on Windows CE + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclWinGetPlatformId(void) +{ + return platformId; +} + +/* + *------------------------------------------------------------------------- + * + * TclWinNoBackslash -- + * + * We're always iterating through a string in Windows, changing the + * backslashes to slashes for use in Tcl. + * + * Results: + * All backslashes in given string are changed to slashes. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +char * +TclWinNoBackslash( + char *path) /* String to change. */ +{ + char *p; + + for (p = path; *p != '\0'; p++) { + if (*p == '\\') { + *p = '/'; + } + } + return path; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpSetInterfaces -- + * + * A helper proc that initializes winTCharEncoding. + * + * Results: + * None. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +void +TclpSetInterfaces(void) +{ + TclWinResetInterfaces(); + winTCharEncoding = Tcl_GetEncoding(NULL, "unicode"); +} + +/* + *--------------------------------------------------------------------------- + * + * TclWinEncodingsCleanup -- + * + * 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 + * used once encodings are taken down. + * + * Results: + * None. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +void +TclWinEncodingsCleanup(void) +{ + MountPointMap *dlIter, *dlIter2; + + TclWinResetInterfaces(); + + /* + * Clean up the mount point map. + */ + + Tcl_MutexLock(&mountPointMap); + dlIter = driveLetterLookup; + while (dlIter != NULL) { + dlIter2 = dlIter->nextPtr; + ckfree(dlIter->volumeName); + ckfree(dlIter); + dlIter = dlIter2; + } + Tcl_MutexUnlock(&mountPointMap); +} + +/* + *--------------------------------------------------------------------------- + * + * TclWinResetInterfaces -- + * + * Called during finalization to reset us to a safe state for reuse. + * + * Results: + * None. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ +void +TclWinResetInterfaces(void) +{ + if (winTCharEncoding != NULL) { + Tcl_FreeEncoding(winTCharEncoding); + winTCharEncoding = NULL; + } +} + +/* + *-------------------------------------------------------------------- + * + * TclWinDriveLetterForVolMountPoint + * + * Unfortunately, Windows provides no easy way at all to get hold of the + * drive letter for a volume mount point, but we need that information to + * understand paths correctly. So, we have to build an associated array + * to find these correctly, and allow quick and easy lookup from volume + * mount points to drive letters. + * + * We assume here that we are running on a system for which the wide + * character interfaces are used, which is valid for Win 2000 and WinXP + * which are the only systems on which this function will ever be called. + * + * Result: + * The drive letter, or -1 if no drive letter corresponds to the given + * mount point. + * + *-------------------------------------------------------------------- + */ + +char +TclWinDriveLetterForVolMountPoint( + const TCHAR *mountPoint) +{ + MountPointMap *dlIter, *dlPtr2; + 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 + * to map a unique volume name to a DOS drive letter. So, we have to build + * an associative array. + */ + + Tcl_MutexLock(&mountPointMap); + dlIter = driveLetterLookup; + while (dlIter != NULL) { + 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] = (TCHAR) dlIter->driveLetter; + + /* + * Try to read the volume mount point and see where it points. + */ + + if (GetVolumeNameForVolumeMountPoint(drive, + Target, 55) != 0) { + if (_tcscmp(dlIter->volumeName, Target) == 0) { + /* + * Nothing has changed. + */ + + Tcl_MutexUnlock(&mountPointMap); + return (char) dlIter->driveLetter; + } + } + + /* + * If we reach here, unfortunately, this mount point is no longer + * valid at all. + */ + + if (driveLetterLookup == dlIter) { + dlPtr2 = dlIter; + driveLetterLookup = dlIter->nextPtr; + } else { + for (dlPtr2 = driveLetterLookup; + dlPtr2 != NULL; dlPtr2 = dlPtr2->nextPtr) { + if (dlPtr2->nextPtr == dlIter) { + dlPtr2->nextPtr = dlIter->nextPtr; + dlPtr2 = dlIter; + break; + } + } + } + + /* + * Now dlPtr2 points to the structure to free. + */ + + ckfree(dlPtr2->volumeName); + ckfree(dlPtr2); + + /* + * Restart the loop - we could try to be clever and continue half + * way through, but the logic is a bit messy, so it's cleanest + * just to restart. + */ + + dlIter = driveLetterLookup; + continue; + } + dlIter = dlIter->nextPtr; + } + + /* + * We couldn't find it, so we must iterate over the letters. + */ + + for (drive[0] = L'A'; drive[0] <= L'Z'; drive[0]++) { + /* + * Try to read the volume mount point and see where it points. + */ + + if (GetVolumeNameForVolumeMountPoint(drive, + Target, 55) != 0) { + int alreadyStored = 0; + + for (dlIter = driveLetterLookup; dlIter != NULL; + dlIter = dlIter->nextPtr) { + if (_tcscmp(dlIter->volumeName, Target) == 0) { + alreadyStored = 1; + break; + } + } + if (!alreadyStored) { + dlPtr2 = ckalloc(sizeof(MountPointMap)); + dlPtr2->volumeName = TclNativeDupInternalRep(Target); + dlPtr2->driveLetter = (char) drive[0]; + dlPtr2->nextPtr = driveLetterLookup; + driveLetterLookup = dlPtr2; + } + } + } + + /* + * Try again. + */ + + for (dlIter = driveLetterLookup; dlIter != NULL; + dlIter = dlIter->nextPtr) { + if (_tcscmp(dlIter->volumeName, mountPoint) == 0) { + Tcl_MutexUnlock(&mountPointMap); + return (char) dlIter->driveLetter; + } + } + + /* + * The volume doesn't appear to correspond to a drive letter - we remember + * that fact and store '-1' so we don't have to look it up each time. + */ + + dlPtr2 = ckalloc(sizeof(MountPointMap)); + dlPtr2->volumeName = TclNativeDupInternalRep((ClientData) mountPoint); + dlPtr2->driveLetter = -1; + dlPtr2->nextPtr = driveLetterLookup; + driveLetterLookup = dlPtr2; + Tcl_MutexUnlock(&mountPointMap); + return -1; +} + +/* + *--------------------------------------------------------------------------- + * + * Tcl_WinUtfToTChar, Tcl_WinTCharToUtf -- + * + * Convert between UTF-8 and Unicode when running Windows NT or the + * current ANSI code page when running Windows 95. + * + * 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 NT, 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 + * "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 + * 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. + * + * Results: + * The result is a pointer to the string in the desired target encoding. + * Storage for the result string is allocated in dsPtr; the caller must + * call Tcl_DStringFree() when the result is no longer needed. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +TCHAR * +Tcl_WinUtfToTChar( + const char *string, /* Source string in UTF-8. */ + int len, /* Source string length in bytes, or < 0 for + * strlen(). */ + Tcl_DString *dsPtr) /* Uninitialized or free DString in which the + * converted string is stored. */ +{ + return (TCHAR *) Tcl_UtfToExternalDString(winTCharEncoding, + string, len, dsPtr); +} + +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 + * platform-specific string length. */ + Tcl_DString *dsPtr) /* Uninitialized or free DString in which the + * converted string is stored. */ +{ + return Tcl_ExternalToUtfDString(winTCharEncoding, + (const char *) string, len, dsPtr); +} + +/* + *------------------------------------------------------------------------ + * + * TclWinCPUID -- + * + * Get CPU ID information on an Intel box under Windows + * + * Results: + * Returns TCL_OK if successful, TCL_ERROR if CPUID is not supported or + * fails. + * + * Side effects: + * If successful, stores EAX, EBX, ECX and EDX registers after the CPUID + * instruction in the four integers designated by 'regsPtr' + * + *---------------------------------------------------------------------- + */ + +int +TclWinCPUID( + int index, /* Which CPUID value to retrieve. */ + int *regsPtr) /* Registers after the CPUID. */ +{ + int status = TCL_ERROR; + +#if defined(HAVE_INTRIN_H) && defined(_WIN64) + + __cpuid(regsPtr, index); + status = TCL_OK; + +#elif defined(__GNUC__) +# if defined(_WIN64) + /* + * Execute the CPUID instruction with the given index, and store results + * off 'regPtr'. + */ + + __asm__ __volatile__( + /* + * Do the CPUID instruction, and save the results in the 'regsPtr' + * area. + */ + + "movl %[rptr], %%edi" "\n\t" + "movl %[index], %%eax" "\n\t" + "cpuid" "\n\t" + "movl %%eax, 0x0(%%edi)" "\n\t" + "movl %%ebx, 0x4(%%edi)" "\n\t" + "movl %%ecx, 0x8(%%edi)" "\n\t" + "movl %%edx, 0xc(%%edi)" "\n\t" + + : + /* No outputs */ + : + [index] "m" (index), + [rptr] "m" (regsPtr) + : + "%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "memory"); + status = TCL_OK; + +# else + + TCLEXCEPTION_REGISTRATION registration; + + /* + * Execute the CPUID instruction with the given index, and store results + * off 'regPtr'. + */ + + __asm__ __volatile__( + /* + * Construct an TCLEXCEPTION_REGISTRATION to protect the CPUID + * instruction (early 486's don't have CPUID) + */ + + "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" + + /* + * Do the CPUID instruction, and save the results in the 'regsPtr' + * area. + */ + + "movl %[rptr], %%edi" "\n\t" + "movl %[index], %%eax" "\n\t" + "cpuid" "\n\t" + "movl %%eax, 0x0(%%edi)" "\n\t" + "movl %%ebx, 0x4(%%edi)" "\n\t" + "movl %%ecx, 0x8(%%edi)" "\n\t" + "movl %%edx, 0xc(%%edi)" "\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\t" + + /* + * 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 */ + : + [index] "m" (index), + [rptr] "m" (regsPtr), + [registration] "m" (registration), + [ok] "i" (TCL_OK), + [error] "i" (TCL_ERROR) + : + "%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "memory"); + status = registration.status; + +# endif /* !_WIN64 */ +#elif defined(_MSC_VER) +# if defined(_WIN64) + + __cpuid(regsPtr, index); + status = TCL_OK; + +# elif defined (_M_IX86) + /* + * Define a structure in the stack frame to hold the registers. + */ + + struct { + DWORD dw0; + DWORD dw1; + DWORD dw2; + DWORD dw3; + } regs; + regs.dw0 = index; + + /* + * Execute the CPUID instruction and save regs in the stack frame. + */ + + _try { + _asm { + push ebx + push ecx + push edx + mov eax, regs.dw0 + cpuid + mov regs.dw0, eax + mov regs.dw1, ebx + mov regs.dw2, ecx + mov regs.dw3, edx + pop edx + pop ecx + pop ebx + } + + /* + * Copy regs back out to the caller. + */ + + regsPtr[0] = regs.dw0; + regsPtr[1] = regs.dw1; + regsPtr[2] = regs.dw2; + regsPtr[3] = regs.dw3; + + status = TCL_OK; + } __except(EXCEPTION_EXECUTE_HANDLER) { + /* do nothing */ + } + +# endif +#else + /* + * Don't know how to do assembly code for this compiler and/or + * architecture. + */ +#endif + return status; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/win/tclWinChan.c b/win/tclWinChan.c new file mode 100644 index 0000000..2898db0 --- /dev/null +++ b/win/tclWinChan.c @@ -0,0 +1,1605 @@ +/* + * tclWinChan.c + * + * Channel drivers for Windows channels based on files, command pipes and + * TCP sockets. + * + * Copyright (c) 1995-1997 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tclWinInt.h" +#include "tclIO.h" + +/* + * State flags used in the info structures below. + */ + +#define FILE_PENDING (1<<0) /* Message is pending in the queue. */ +#define FILE_ASYNC (1<<1) /* Channel is non-blocking. */ +#define FILE_APPEND (1<<2) /* File is in append mode. */ + +#define FILE_TYPE_SERIAL (FILE_TYPE_PIPE+1) +#define FILE_TYPE_CONSOLE (FILE_TYPE_PIPE+2) + +/* + * The following structure contains per-instance data for a file based + * channel. + */ + +typedef struct FileInfo { + Tcl_Channel channel; /* Pointer to channel structure. */ + int validMask; /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, or TCL_EXCEPTION: indicates + * which operations are valid on the file. */ + int watchMask; /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, or TCL_EXCEPTION: indicates + * which events should be reported. */ + int flags; /* State flags, see above for a list. */ + HANDLE handle; /* Input/output file. */ + struct FileInfo *nextPtr; /* Pointer to next registered file. */ + int dirty; /* Boolean flag. Set if the OS may have data + * pending on the channel. */ +} FileInfo; + +typedef struct { + /* + * List of all file channels currently open. + */ + + FileInfo *firstFilePtr; +} ThreadSpecificData; + +static Tcl_ThreadDataKey dataKey; + +/* + * The following structure is what is added to the Tcl event queue when file + * events are generated. + */ + +typedef struct { + Tcl_Event header; /* Information that is standard for all + * events. */ + FileInfo *infoPtr; /* Pointer to file info structure. Note that + * we still have to verify that the file + * exists before dereferencing this + * pointer. */ +} FileEvent; + +/* + * Static routines for this file: + */ + +static int FileBlockProc(ClientData instanceData, int mode); +static void FileChannelExitHandler(ClientData clientData); +static void FileCheckProc(ClientData clientData, int flags); +static int FileCloseProc(ClientData instanceData, + Tcl_Interp *interp); +static int FileEventProc(Tcl_Event *evPtr, int flags); +static int FileGetHandleProc(ClientData instanceData, + int direction, ClientData *handlePtr); +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); +static int FileSeekProc(ClientData instanceData, long offset, + int mode, int *errorCode); +static Tcl_WideInt FileWideSeekProc(ClientData instanceData, + Tcl_WideInt offset, int mode, int *errorCode); +static void FileSetupProc(ClientData clientData, int flags); +static void FileWatchProc(ClientData instanceData, int mask); +static void FileThreadActionProc(ClientData instanceData, + int action); +static int FileTruncateProc(ClientData instanceData, + Tcl_WideInt length); +static DWORD FileGetType(HANDLE handle); +static int NativeIsComPort(const TCHAR *nativeName); + +/* + * This structure describes the channel type structure for file based IO. + */ + +static const Tcl_ChannelType fileChannelType = { + "file", /* Type name. */ + TCL_CHANNEL_VERSION_5, /* v5 channel */ + FileCloseProc, /* Close proc. */ + FileInputProc, /* Input proc. */ + FileOutputProc, /* Output proc. */ + FileSeekProc, /* Seek proc. */ + NULL, /* Set option proc. */ + NULL, /* Get option proc. */ + FileWatchProc, /* Set up the notifier to watch the channel. */ + FileGetHandleProc, /* Get an OS handle from channel. */ + NULL, /* close2proc. */ + FileBlockProc, /* Set blocking or non-blocking mode.*/ + NULL, /* flush proc. */ + NULL, /* handler proc. */ + FileWideSeekProc, /* Wide seek proc. */ + FileThreadActionProc, /* Thread action proc. */ + FileTruncateProc /* Truncate proc. */ +}; + +/* + * General useful clarification macros. + */ + +#define SET_FLAG(var, flag) ((var) |= (flag)) +#define CLEAR_FLAG(var, flag) ((var) &= ~(flag)) +#define TEST_FLAG(value, flag) (((value) & (flag)) != 0) + +/* + *---------------------------------------------------------------------- + * + * FileInit -- + * + * This function creates the window used to simulate file events. + * + * Results: + * None. + * + * Side effects: + * Creates a new window and creates an exit handler. + * + *---------------------------------------------------------------------- + */ + +static ThreadSpecificData * +FileInit(void) +{ + ThreadSpecificData *tsdPtr = + (ThreadSpecificData *) TclThreadDataKeyGet(&dataKey); + + if (tsdPtr == NULL) { + tsdPtr = TCL_TSD_INIT(&dataKey); + tsdPtr->firstFilePtr = NULL; + Tcl_CreateEventSource(FileSetupProc, FileCheckProc, NULL); + Tcl_CreateThreadExitHandler(FileChannelExitHandler, NULL); + } + return tsdPtr; +} + +/* + *---------------------------------------------------------------------- + * + * FileChannelExitHandler -- + * + * This function is called to cleanup the channel driver before Tcl is + * unloaded. + * + * Results: + * None. + * + * Side effects: + * Destroys the communication window. + * + *---------------------------------------------------------------------- + */ + +static void +FileChannelExitHandler( + ClientData clientData) /* Old window proc */ +{ + Tcl_DeleteEventSource(FileSetupProc, FileCheckProc, NULL); +} + +/* + *---------------------------------------------------------------------- + * + * FileSetupProc -- + * + * This function is invoked before Tcl_DoOneEvent blocks waiting for an + * event. + * + * Results: + * None. + * + * Side effects: + * Adjusts the block time if needed. + * + *---------------------------------------------------------------------- + */ + +void +FileSetupProc( + ClientData data, /* Not used. */ + int flags) /* Event flags as passed to Tcl_DoOneEvent. */ +{ + FileInfo *infoPtr; + Tcl_Time blockTime = { 0, 0 }; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if (!TEST_FLAG(flags, TCL_FILE_EVENTS)) { + return; + } + + /* + * Check to see if there is a ready file. If so, poll. + */ + + for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL; + infoPtr = infoPtr->nextPtr) { + if (infoPtr->watchMask) { + Tcl_SetMaxBlockTime(&blockTime); + break; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * FileCheckProc -- + * + * This function is called by Tcl_DoOneEvent to check the file event + * source for events. + * + * Results: + * None. + * + * Side effects: + * May queue an event. + * + *---------------------------------------------------------------------- + */ + +static void +FileCheckProc( + ClientData data, /* Not used. */ + int flags) /* Event flags as passed to Tcl_DoOneEvent. */ +{ + FileEvent *evPtr; + FileInfo *infoPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if (!TEST_FLAG(flags, TCL_FILE_EVENTS)) { + return; + } + + /* + * Queue events for any ready files that don't already have events queued + * (caused by persistent states that won't generate WinSock events). + */ + + for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL; + infoPtr = infoPtr->nextPtr) { + if (infoPtr->watchMask && !TEST_FLAG(infoPtr->flags, FILE_PENDING)) { + SET_FLAG(infoPtr->flags, FILE_PENDING); + evPtr = ckalloc(sizeof(FileEvent)); + evPtr->header.proc = FileEventProc; + evPtr->infoPtr = infoPtr; + Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * FileEventProc -- + * + * This function is invoked by Tcl_ServiceEvent when a file event reaches + * the front of the event queue. This function invokes Tcl_NotifyChannel + * on the file. + * + * 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. + * + * Side effects: + * Whatever the notifier callback does. + * + *---------------------------------------------------------------------- + */ + +static int +FileEventProc( + Tcl_Event *evPtr, /* Event to service. */ + int flags) /* Flags that indicate what events to handle, + * such as TCL_FILE_EVENTS. */ +{ + FileEvent *fileEvPtr = (FileEvent *)evPtr; + FileInfo *infoPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if (!TEST_FLAG(flags, TCL_FILE_EVENTS)) { + return 0; + } + + /* + * Search through the list of watched files for the one whose handle + * matches the event. We do this rather than simply dereferencing the + * handle in the event so that files can be deleted while the event is in + * the queue. + */ + + for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL; + infoPtr = infoPtr->nextPtr) { + if (fileEvPtr->infoPtr == infoPtr) { + CLEAR_FLAG(infoPtr->flags, FILE_PENDING); + Tcl_NotifyChannel(infoPtr->channel, infoPtr->watchMask); + break; + } + } + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * FileBlockProc -- + * + * Set blocking or non-blocking mode on channel. + * + * Results: + * 0 if successful, errno when failed. + * + * Side effects: + * Sets the device into blocking or non-blocking mode. + * + *---------------------------------------------------------------------- + */ + +static int +FileBlockProc( + ClientData instanceData, /* Instance data for channel. */ + int mode) /* TCL_MODE_BLOCKING or + * TCL_MODE_NONBLOCKING. */ +{ + FileInfo *infoPtr = instanceData; + + /* + * Files on Windows can not be switched between blocking and nonblocking, + * hence we have to emulate the behavior. This is done in the input + * function by checking against a bit in the state. We set or unset the + * bit here to cause the input function to emulate the correct behavior. + */ + + if (mode == TCL_MODE_NONBLOCKING) { + SET_FLAG(infoPtr->flags, FILE_ASYNC); + } else { + CLEAR_FLAG(infoPtr->flags, FILE_ASYNC); + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * FileCloseProc -- + * + * Closes the IO channel. + * + * Results: + * 0 if successful, the value of errno if failed. + * + * Side effects: + * Closes the physical channel + * + *---------------------------------------------------------------------- + */ + +static int +FileCloseProc( + ClientData instanceData, /* Pointer to FileInfo structure. */ + Tcl_Interp *interp) /* Not used. */ +{ + FileInfo *fileInfoPtr = instanceData; + FileInfo *infoPtr; + ThreadSpecificData *tsdPtr; + int errorCode = 0; + + /* + * Remove the file from the watch list. + */ + + FileWatchProc(instanceData, 0); + + /* + * 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 + * another. + */ + + if (!TclInThreadExit() + || ((GetStdHandle(STD_INPUT_HANDLE) != fileInfoPtr->handle) + && (GetStdHandle(STD_OUTPUT_HANDLE) != fileInfoPtr->handle) + && (GetStdHandle(STD_ERROR_HANDLE) != fileInfoPtr->handle))) { + if (CloseHandle(fileInfoPtr->handle) == FALSE) { + TclWinConvertError(GetLastError()); + errorCode = errno; + } + } + + /* + * See if this FileInfo* is still on the thread local list. + */ + + tsdPtr = TCL_TSD_INIT(&dataKey); + for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL; + infoPtr = infoPtr->nextPtr) { + if (infoPtr == fileInfoPtr) { + /* + * This channel exists on the thread local list. It should have + * been removed by an earlier Threadaction call, but do that now + * since just deallocating fileInfoPtr would leave an deallocated + * pointer on the thread local list. + */ + + FileThreadActionProc(fileInfoPtr,TCL_CHANNEL_THREAD_REMOVE); + break; + } + } + ckfree(fileInfoPtr); + return errorCode; +} + +/* + *---------------------------------------------------------------------- + * + * FileSeekProc -- + * + * Seeks on a file-based channel. Returns the new position. + * + * Results: + * -1 if failed, the new position if successful. If failed, it also sets + * *errorCodePtr to the error code. + * + * Side effects: + * Moves the location at which the channel will be accessed in future + * operations. + * + *---------------------------------------------------------------------- + */ + +static int +FileSeekProc( + ClientData instanceData, /* File state. */ + long offset, /* Offset to seek to. */ + int mode, /* Relative to where should we seek? */ + int *errorCodePtr) /* To store error code. */ +{ + FileInfo *infoPtr = instanceData; + LONG newPos, newPosHigh, oldPos, oldPosHigh; + DWORD moveMethod; + + *errorCodePtr = 0; + if (mode == SEEK_SET) { + moveMethod = FILE_BEGIN; + } else if (mode == SEEK_CUR) { + moveMethod = FILE_CURRENT; + } else { + moveMethod = FILE_END; + } + + /* + * Save our current place in case we need to roll-back the seek. + */ + + oldPosHigh = 0; + oldPos = SetFilePointer(infoPtr->handle, 0, &oldPosHigh, FILE_CURRENT); + if (oldPos == (LONG) INVALID_SET_FILE_POINTER) { + DWORD winError = GetLastError(); + + if (winError != NO_ERROR) { + TclWinConvertError(winError); + *errorCodePtr = errno; + return -1; + } + } + + newPosHigh = (offset < 0 ? -1 : 0); + newPos = SetFilePointer(infoPtr->handle, offset, &newPosHigh, moveMethod); + if (newPos == (LONG) INVALID_SET_FILE_POINTER) { + DWORD winError = GetLastError(); + + if (winError != NO_ERROR) { + TclWinConvertError(winError); + *errorCodePtr = errno; + return -1; + } + } + + /* + * Check for expressability in our return type, and roll-back otherwise. + */ + + if (newPosHigh != 0) { + *errorCodePtr = EOVERFLOW; + SetFilePointer(infoPtr->handle, oldPos, &oldPosHigh, FILE_BEGIN); + return -1; + } + return (int) newPos; +} + +/* + *---------------------------------------------------------------------- + * + * FileWideSeekProc -- + * + * Seeks on a file-based channel. Returns the new position. + * + * Results: + * -1 if failed, the new position if successful. If failed, it also sets + * *errorCodePtr to the error code. + * + * Side effects: + * Moves the location at which the channel will be accessed in future + * operations. + * + *---------------------------------------------------------------------- + */ + +static Tcl_WideInt +FileWideSeekProc( + ClientData instanceData, /* File state. */ + Tcl_WideInt offset, /* Offset to seek to. */ + int mode, /* Relative to where should we seek? */ + int *errorCodePtr) /* To store error code. */ +{ + FileInfo *infoPtr = instanceData; + DWORD moveMethod; + LONG newPos, newPosHigh; + + *errorCodePtr = 0; + if (mode == SEEK_SET) { + moveMethod = FILE_BEGIN; + } else if (mode == SEEK_CUR) { + moveMethod = FILE_CURRENT; + } else { + moveMethod = FILE_END; + } + + newPosHigh = Tcl_WideAsLong(offset >> 32); + newPos = SetFilePointer(infoPtr->handle, Tcl_WideAsLong(offset), + &newPosHigh, moveMethod); + if (newPos == (LONG) INVALID_SET_FILE_POINTER) { + DWORD winError = GetLastError(); + + if (winError != NO_ERROR) { + TclWinConvertError(winError); + *errorCodePtr = errno; + return -1; + } + } + return (((Tcl_WideInt)((unsigned)newPos)) + | (Tcl_LongAsWide(newPosHigh) << 32)); +} + +/* + *---------------------------------------------------------------------- + * + * FileTruncateProc -- + * + * Truncates a file-based channel. Returns the error code. + * + * Results: + * 0 if successful, POSIX-y error code if it failed. + * + * Side effects: + * Truncates the file, may move file pointers too. + * + *---------------------------------------------------------------------- + */ + +static int +FileTruncateProc( + ClientData instanceData, /* File state. */ + Tcl_WideInt length) /* Length to truncate at. */ +{ + FileInfo *infoPtr = instanceData; + LONG newPos, newPosHigh, oldPos, oldPosHigh; + + /* + * Save where we were... + */ + + oldPosHigh = 0; + oldPos = SetFilePointer(infoPtr->handle, 0, &oldPosHigh, FILE_CURRENT); + if (oldPos == (LONG) INVALID_SET_FILE_POINTER) { + DWORD winError = GetLastError(); + + if (winError != NO_ERROR) { + TclWinConvertError(winError); + return errno; + } + } + + /* + * Move to where we want to truncate + */ + + newPosHigh = Tcl_WideAsLong(length >> 32); + newPos = SetFilePointer(infoPtr->handle, Tcl_WideAsLong(length), + &newPosHigh, FILE_BEGIN); + if (newPos == (LONG) INVALID_SET_FILE_POINTER) { + DWORD winError = GetLastError(); + + if (winError != NO_ERROR) { + TclWinConvertError(winError); + return errno; + } + } + + /* + * Perform the truncation (unlike POSIX ftruncate(), we needed to move to + * the location to truncate at first). + */ + + if (!SetEndOfFile(infoPtr->handle)) { + TclWinConvertError(GetLastError()); + return errno; + } + + /* + * Move back. If this last step fails, we don't care; it's just a "best + * effort" attempt to restore our file pointer to where it was. + */ + + SetFilePointer(infoPtr->handle, oldPos, &oldPosHigh, FILE_BEGIN); + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * FileInputProc -- + * + * Reads input from the IO channel into the buffer given. Returns count + * of how many bytes were actually read, and an error indication. + * + * Results: + * A count of how many bytes were read is returned and an error + * indication is returned in an output argument. + * + * Side effects: + * Reads input from the actual channel. + * + *---------------------------------------------------------------------- + */ + +static int +FileInputProc( + ClientData instanceData, /* File state. */ + char *buf, /* Where to store data read. */ + int bufSize, /* Num bytes available in buffer. */ + int *errorCode) /* Where to store error code. */ +{ + FileInfo *infoPtr = instanceData; + DWORD bytesRead; + + *errorCode = 0; + + /* + * 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 + * for now, we just block. The same problem exists for files being read + * over the network. + */ + + if (ReadFile(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize, &bytesRead, + (LPOVERLAPPED) NULL) != FALSE) { + return bytesRead; + } + + TclWinConvertError(GetLastError()); + *errorCode = errno; + if (errno == EPIPE) { + return 0; + } + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * FileOutputProc -- + * + * Writes the given output on the IO channel. Returns count of how many + * characters were actually written, and an error indication. + * + * Results: + * A count of how many characters were written is returned and an error + * indication is returned in an output argument. + * + * Side effects: + * Writes output on the actual channel. + * + *---------------------------------------------------------------------- + */ + +static int +FileOutputProc( + ClientData instanceData, /* File state. */ + const char *buf, /* The data buffer. */ + int toWrite, /* How many bytes to write? */ + int *errorCode) /* Where to store error code. */ +{ + FileInfo *infoPtr = instanceData; + DWORD bytesWritten; + + *errorCode = 0; + + /* + * If we are writing to a file that was opened with O_APPEND, we need to + * seek to the end of the file before writing the current buffer. + */ + + if (TEST_FLAG(infoPtr->flags, FILE_APPEND)) { + SetFilePointer(infoPtr->handle, 0, NULL, FILE_END); + } + + if (WriteFile(infoPtr->handle, (LPVOID) buf, (DWORD) toWrite, + &bytesWritten, (LPOVERLAPPED) NULL) == FALSE) { + TclWinConvertError(GetLastError()); + *errorCode = errno; + return -1; + } + infoPtr->dirty = 1; + return bytesWritten; +} + +/* + *---------------------------------------------------------------------- + * + * FileWatchProc -- + * + * Called by the notifier to set up to watch for events on this channel. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +FileWatchProc( + ClientData instanceData, /* File state. */ + int mask) /* What events to watch for; OR-ed combination + * of TCL_READABLE, TCL_WRITABLE and + * TCL_EXCEPTION. */ +{ + FileInfo *infoPtr = instanceData; + Tcl_Time blockTime = { 0, 0 }; + + /* + * Since the file is always ready for events, we set the block time to + * zero so we will poll. + */ + + infoPtr->watchMask = mask & infoPtr->validMask; + if (infoPtr->watchMask) { + Tcl_SetMaxBlockTime(&blockTime); + } +} + +/* + *---------------------------------------------------------------------- + * + * FileGetHandleProc -- + * + * Called from Tcl_GetChannelHandle to retrieve OS handles from a file + * 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. + * + *---------------------------------------------------------------------- + */ + +static int +FileGetHandleProc( + ClientData instanceData, /* The file state. */ + int direction, /* TCL_READABLE or TCL_WRITABLE */ + ClientData *handlePtr) /* Where to store the handle. */ +{ + FileInfo *infoPtr = instanceData; + + if (!TEST_FLAG(direction, infoPtr->validMask)) { + return TCL_ERROR; + } + + *handlePtr = (ClientData) infoPtr->handle; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclpOpenFileChannel -- + * + * Open an File based channel on Unix systems. + * + * Results: + * The new channel or NULL. If NULL, the output argument errorCodePtr is + * set to a POSIX error. + * + * Side effects: + * May open the channel and may cause creation of a file on the file + * system. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +TclpOpenFileChannel( + Tcl_Interp *interp, /* Interpreter for error reporting; can be + * NULL. */ + Tcl_Obj *pathPtr, /* Name of file to open. */ + int mode, /* POSIX mode. */ + int permissions) /* If the open involves creating a file, with + * what modes to create it? */ +{ + Tcl_Channel channel = 0; + int channelPermissions = 0; + DWORD accessMode = 0, createMode, shareMode, flags; + const TCHAR *nativeName; + HANDLE handle; + char channelName[16 + TCL_INTEGER_SPACE]; + TclFile readFile = NULL, writeFile = NULL; + + nativeName = Tcl_FSGetNativePath(pathPtr); + if (nativeName == NULL) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open \"%s\": filename is invalid on this platform", + TclGetString(pathPtr))); + } + return NULL; + } + + switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) { + case O_RDONLY: + accessMode = GENERIC_READ; + channelPermissions = TCL_READABLE; + break; + case O_WRONLY: + accessMode = GENERIC_WRITE; + channelPermissions = TCL_WRITABLE; + break; + case O_RDWR: + accessMode = (GENERIC_READ | GENERIC_WRITE); + channelPermissions = (TCL_READABLE | TCL_WRITABLE); + break; + default: + Tcl_Panic("TclpOpenFileChannel: invalid mode value"); + break; + } + + /* + * Map the creation flags to the NT create mode. + */ + + switch (mode & (O_CREAT | O_EXCL | O_TRUNC)) { + case (O_CREAT | O_EXCL): + case (O_CREAT | O_EXCL | O_TRUNC): + createMode = CREATE_NEW; + break; + case (O_CREAT | O_TRUNC): + createMode = CREATE_ALWAYS; + break; + case O_CREAT: + createMode = OPEN_ALWAYS; + break; + case O_TRUNC: + case (O_TRUNC | O_EXCL): + createMode = TRUNCATE_EXISTING; + break; + default: + createMode = OPEN_EXISTING; + break; + } + + /* + * [2413550] Avoid double-open of serial ports on Windows. Special + * handling for Windows serial ports by a "name-hint" to directly open it + * with the OVERLAPPED flag set. + */ + + if (NativeIsComPort(nativeName)) { + handle = TclWinSerialOpen(INVALID_HANDLE_VALUE, nativeName, accessMode); + if (handle == INVALID_HANDLE_VALUE) { + TclWinConvertError(GetLastError()); + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open serial \"%s\": %s", + TclGetString(pathPtr), Tcl_PosixError(interp))); + } + return NULL; + } + + /* + * For natively named Windows serial ports we are done. + */ + + channel = TclWinOpenSerialChannel(handle, channelName, + channelPermissions); + + return channel; + } + + /* + * If the file is being created, get the file attributes from the + * permissions argument, else use the existing file attributes. + */ + + if (TEST_FLAG(mode, O_CREAT)) { + if (TEST_FLAG(permissions, S_IWRITE)) { + flags = FILE_ATTRIBUTE_NORMAL; + } else { + flags = FILE_ATTRIBUTE_READONLY; + } + } else { + flags = GetFileAttributes(nativeName); + if (flags == 0xFFFFFFFF) { + flags = 0; + } + } + + /* + * Set up the file sharing mode. We want to allow simultaneous access. + */ + + shareMode = FILE_SHARE_READ | FILE_SHARE_WRITE; + + /* + * Now we get to create the file. + */ + + handle = CreateFile(nativeName, accessMode, shareMode, + NULL, createMode, flags, (HANDLE) NULL); + + if (handle == INVALID_HANDLE_VALUE) { + DWORD err = GetLastError(); + + if ((err & 0xffffL) == ERROR_OPEN_FAILED) { + err = TEST_FLAG(mode, O_CREAT) ? ERROR_FILE_EXISTS + : ERROR_FILE_NOT_FOUND; + } + TclWinConvertError(err); + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open \"%s\": %s", + TclGetString(pathPtr), Tcl_PosixError(interp))); + } + return NULL; + } + + channel = NULL; + + switch (FileGetType(handle)) { + case FILE_TYPE_SERIAL: + /* + * Natively named serial ports "com1-9", "\\\\.\\comXX" are already + * done with the code above. Here we handle all other serial port + * names. + * + * Reopen channel for OVERLAPPED operation. Normally this shouldn't + * fail, because the channel exists. + */ + + handle = TclWinSerialOpen(handle, nativeName, accessMode); + if (handle == INVALID_HANDLE_VALUE) { + TclWinConvertError(GetLastError()); + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't reopen serial \"%s\": %s", + TclGetString(pathPtr), Tcl_PosixError(interp))); + } + return NULL; + } + channel = TclWinOpenSerialChannel(handle, channelName, + channelPermissions); + break; + case FILE_TYPE_CONSOLE: + channel = TclWinOpenConsoleChannel(handle, channelName, + channelPermissions); + break; + case FILE_TYPE_PIPE: + if (TEST_FLAG(channelPermissions, TCL_READABLE)) { + readFile = TclWinMakeFile(handle); + } + if (TEST_FLAG(channelPermissions, TCL_WRITABLE)) { + writeFile = TclWinMakeFile(handle); + } + channel = TclpCreateCommandChannel(readFile, writeFile, NULL, 0, NULL); + break; + case FILE_TYPE_CHAR: + case FILE_TYPE_DISK: + case FILE_TYPE_UNKNOWN: + channel = TclWinOpenFileChannel(handle, channelName, + channelPermissions, + TEST_FLAG(mode, O_APPEND) ? FILE_APPEND : 0); + break; + + default: + /* + * The handle is of an unknown type, probably /dev/nul equivalent or + * possibly a closed handle. + */ + + channel = NULL; + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open \"%s\": bad file type", + TclGetString(pathPtr))); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "BAD_TYPE", + NULL); + break; + } + + return channel; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_MakeFileChannel -- + * + * Creates a Tcl_Channel from an existing platform specific file handle. + * + * Results: + * The Tcl_Channel created around the preexisting file. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_MakeFileChannel( + ClientData rawHandle, /* OS level handle */ + int mode) /* ORed combination of TCL_READABLE and + * TCL_WRITABLE to indicate file mode. */ +{ +#if defined(HAVE_NO_SEH) && !defined(_WIN64) + TCLEXCEPTION_REGISTRATION registration; +#endif + char channelName[16 + TCL_INTEGER_SPACE]; + Tcl_Channel channel = NULL; + HANDLE handle = (HANDLE) rawHandle; + HANDLE dupedHandle; + TclFile readFile = NULL, writeFile = NULL; + BOOL result; + + if (mode == 0) { + return NULL; + } + + switch (FileGetType(handle)) { + case FILE_TYPE_SERIAL: + channel = TclWinOpenSerialChannel(handle, channelName, mode); + break; + case FILE_TYPE_CONSOLE: + channel = TclWinOpenConsoleChannel(handle, channelName, mode); + break; + case FILE_TYPE_PIPE: + if (TEST_FLAG(mode, TCL_READABLE)) { + readFile = TclWinMakeFile(handle); + } + if (TEST_FLAG(mode, TCL_WRITABLE)) { + writeFile = TclWinMakeFile(handle); + } + channel = TclpCreateCommandChannel(readFile, writeFile, NULL, 0, NULL); + break; + + case FILE_TYPE_DISK: + case FILE_TYPE_CHAR: + channel = TclWinOpenFileChannel(handle, channelName, mode, 0); + break; + + case FILE_TYPE_UNKNOWN: + default: + /* + * The handle is of an unknown type. Test the validity of this OS + * handle by duplicating it, then closing the dupe. The Win32 API + * doesn't provide an IsValidHandle() function, so we have to emulate + * it here. This test will not work on a console handle reliably, + * which is why we can't test every handle that comes into this + * function in this way. + */ + + result = DuplicateHandle(GetCurrentProcess(), handle, + GetCurrentProcess(), &dupedHandle, 0, FALSE, + DUPLICATE_SAME_ACCESS); + + if (result == 0) { + /* + * Unable to make a duplicate. It's definately invalid at this + * point. + */ + + return NULL; + } + + /* + * Use structured exception handling (Win32 SEH) to protect the close + * of this duped handle which might throw EXCEPTION_INVALID_HANDLE. + */ + + result = 0; +#if defined(HAVE_NO_SEH) && !defined(_WIN64) + /* + * Don't have SEH available, do things the hard way. Note that this + * needs to be one block of asm, to avoid stack imbalance; also, it is + * illegal for one asm block to contain a jump to another. + */ + + __asm__ __volatile__ ( + + /* + * Pick up parameters before messing with the stack + */ + + "movl %[dupedHandle], %%ebx" "\n\t" + + /* + * Construct an TCLEXCEPTION_REGISTRATION to protect the call to + * CloseHandle. + */ + + "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 $0, 0x10(%%edx)" "\n\t" /* status */ + + /* + * Link the TCLEXCEPTION_REGISTRATION on the chain. + */ + + "movl %%edx, %%fs:0" "\n\t" + + /* + * Call CloseHandle(dupedHandle). + */ + + "pushl %%ebx" "\n\t" + "call _CloseHandle@4" "\n\t" + + /* + * Come here on normal exit. Recover the TCLEXCEPTION_REGISTRATION + * and put a TRUE status return into it. + */ + + "movl %%fs:0, %%edx" "\n\t" + "movl $1, %%eax" "\n\t" + "movl %%eax, 0x10(%%edx)" "\n\t" + "jmp 2f" "\n" + + /* + * Come here on an exception. Recover the TCLEXCEPTION_REGISTRATION + */ + + "1:" "\t" + "movl %%fs:0, %%edx" "\n\t" + "movl 0x8(%%edx), %%edx" "\n\t" + + /* + * 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), + [dupedHandle] "m" (dupedHandle) + : + "%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "memory" + ); + result = registration.status; +#else +#ifndef HAVE_NO_SEH + __try { +#endif + CloseHandle(dupedHandle); + result = 1; +#ifndef HAVE_NO_SEH + } __except (EXCEPTION_EXECUTE_HANDLER) {} +#endif +#endif + if (result == FALSE) { + return NULL; + } + + /* + * Fall through, the handle is valid. + * + * Create the undefined channel, anyways, because we know the handle + * is valid to something. + */ + + channel = TclWinOpenFileChannel(handle, channelName, mode, 0); + } + + return channel; +} + +/* + *---------------------------------------------------------------------- + * + * TclpGetDefaultStdChannel -- + * + * Constructs a channel for the specified standard OS handle. + * + * Results: + * Returns the specified default standard channel, or NULL. + * + * Side effects: + * May cause the creation of a standard channel and the underlying file. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +TclpGetDefaultStdChannel( + int type) /* One of TCL_STDIN, TCL_STDOUT, or + * TCL_STDERR. */ +{ + Tcl_Channel channel; + HANDLE handle; + int mode = -1; + const char *bufMode = NULL; + DWORD handleId = (DWORD) -1; + /* Standard handle to retrieve. */ + + switch (type) { + case TCL_STDIN: + handleId = STD_INPUT_HANDLE; + mode = TCL_READABLE; + bufMode = "line"; + break; + case TCL_STDOUT: + handleId = STD_OUTPUT_HANDLE; + mode = TCL_WRITABLE; + bufMode = "line"; + break; + case TCL_STDERR: + handleId = STD_ERROR_HANDLE; + mode = TCL_WRITABLE; + bufMode = "none"; + break; + default: + Tcl_Panic("TclGetDefaultStdChannel: Unexpected channel type"); + break; + } + + handle = GetStdHandle(handleId); + + /* + * Note that we need to check for 0 because Windows may return 0 if this + * is not a console mode application, even though this is not a valid + * handle. + */ + + if ((handle == INVALID_HANDLE_VALUE) || (handle == 0)) { + return (Tcl_Channel) NULL; + } + + channel = Tcl_MakeFileChannel(handle, mode); + + if (channel == NULL) { + return (Tcl_Channel) NULL; + } + + /* + * Set up the normal channel options for stdio handles. + */ + + if (Tcl_SetChannelOption(NULL,channel,"-translation","auto")!=TCL_OK || + Tcl_SetChannelOption(NULL,channel,"-eofchar","\032 {}")!=TCL_OK || + Tcl_SetChannelOption(NULL,channel,"-buffering",bufMode)!=TCL_OK) { + Tcl_Close(NULL, channel); + return (Tcl_Channel) NULL; + } + return channel; +} + +/* + *---------------------------------------------------------------------- + * + * TclWinOpenFileChannel -- + * + * Constructs a File channel for the specified standard OS handle. This + * is a helper function to break up the construction of channels into + * File, Console, or Serial. + * + * Results: + * Returns the new channel, or NULL. + * + * Side effects: + * May open the channel and may cause creation of a file on the file + * system. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +TclWinOpenFileChannel( + HANDLE handle, /* Win32 HANDLE to swallow */ + char *channelName, /* Buffer to receive channel name */ + int permissions, /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, or TCL_EXCEPTION, indicating + * which operations are valid on the file. */ + int appendMode) /* OR'ed combination of bits indicating what + * additional configuration of the channel is + * present. */ +{ + FileInfo *infoPtr; + ThreadSpecificData *tsdPtr = FileInit(); + + /* + * See if a channel with this handle already exists. + */ + + for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL; + infoPtr = infoPtr->nextPtr) { + if (infoPtr->handle == (HANDLE) handle) { + return (permissions==infoPtr->validMask) ? infoPtr->channel : NULL; + } + } + + infoPtr = ckalloc(sizeof(FileInfo)); + + /* + * 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. + */ + + infoPtr->nextPtr = NULL; + infoPtr->validMask = permissions; + infoPtr->watchMask = 0; + infoPtr->flags = appendMode; + infoPtr->handle = handle; + infoPtr->dirty = 0; + sprintf(channelName, "file%" TCL_I_MODIFIER "x", (size_t) infoPtr); + + infoPtr->channel = Tcl_CreateChannel(&fileChannelType, channelName, + infoPtr, permissions); + + /* + * Files have default translation of AUTO and ^Z eof char, which means + * that a ^Z will be accepted as EOF when reading. + */ + + Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto"); + Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}"); + + return infoPtr->channel; +} + +/* + *---------------------------------------------------------------------- + * + * TclWinFlushDirtyChannels -- + * + * Flush all dirty channels to disk, so that requesting the size of any + * file returns the correct value. + * + * Results: + * None. + * + * Side effects: + * Information is actually written to disk now, rather than later. Don't + * call this too often, or there will be a performance hit (i.e. only + * call when we need to ask for the size of a file). + * + *---------------------------------------------------------------------- + */ + +void +TclWinFlushDirtyChannels(void) +{ + FileInfo *infoPtr; + ThreadSpecificData *tsdPtr = FileInit(); + + /* + * Flush all channels which are dirty, i.e. may have data pending in the + * OS. + */ + + for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL; + infoPtr = infoPtr->nextPtr) { + if (infoPtr->dirty) { + FlushFileBuffers(infoPtr->handle); + infoPtr->dirty = 0; + } + } +} + +/* + *---------------------------------------------------------------------- + * + * FileThreadActionProc -- + * + * Insert or remove any thread local refs to this channel. + * + * Results: + * None. + * + * Side effects: + * Changes thread local list of valid channels. + * + *---------------------------------------------------------------------- + */ + +static void +FileThreadActionProc( + ClientData instanceData, + int action) +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + FileInfo *infoPtr = instanceData; + + if (action == TCL_CHANNEL_THREAD_INSERT) { + infoPtr->nextPtr = tsdPtr->firstFilePtr; + tsdPtr->firstFilePtr = infoPtr; + } else { + FileInfo **nextPtrPtr; + int removed = 0; + + for (nextPtrPtr = &(tsdPtr->firstFilePtr); (*nextPtrPtr) != NULL; + nextPtrPtr = &((*nextPtrPtr)->nextPtr)) { + if ((*nextPtrPtr) == infoPtr) { + (*nextPtrPtr) = infoPtr->nextPtr; + removed = 1; + break; + } + } + + /* + * This could happen if the channel was created in one thread and then + * moved to another without updating the thread local data in each + * thread. + */ + + if (!removed) { + Tcl_Panic("file info ptr not on thread channel list"); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * FileGetType -- + * + * Given a file handle, return its type + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +DWORD +FileGetType( + HANDLE handle) /* Opened file handle */ +{ + DWORD type; + + type = GetFileType(handle); + + /* + * If the file is a character device, we need to try to figure out whether + * it is a serial port, a console, or something else. We test for the + * console case first because this is more common. + */ + + if ((type == FILE_TYPE_CHAR) + || ((type == FILE_TYPE_UNKNOWN) && !GetLastError())) { + DWORD consoleParams; + + if (GetConsoleMode(handle, &consoleParams)) { + type = FILE_TYPE_CONSOLE; + } else { + DCB dcb; + + dcb.DCBlength = sizeof(DCB); + if (GetCommState(handle, &dcb)) { + type = FILE_TYPE_SERIAL; + } + } + } + + return type; +} + + /* + *---------------------------------------------------------------------- + * + * 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 to detect serialness + * after the fact. + * + * The following patterns cover common serial port names: + * COM[1-9] + * \\.\COM[0-9]+ + * + * Results: + * 1 = serial port, 0 = not. + * + *---------------------------------------------------------------------- + */ + +static int +NativeIsComPort( + const TCHAR *nativePath) /* Path of file to access, native encoding. */ +{ + const WCHAR *p = (const WCHAR *) nativePath; + int i, len = wcslen(p); + + /* + * 1. Look for com[1-9]:? + */ + + if ((len == 4) && (_wcsnicmp(p, L"com", 3) == 0)) { + /* + * The 4th character must be a digit 1..9 + */ + + if ((p[3] < L'1') || (p[3] > L'9')) { + return 0; + } + return 1; + } + + /* + * 2. Look for \\.\com[0-9]+ + */ + + if ((len >= 8) && (_wcsnicmp(p, L"\\\\.\\com", 7) == 0)) { + /* + * Charaters 8..end must be a digits 0..9 + */ + + for (i=7; i<len; i++) { + if ((p[i] < '0') || (p[i] > '9')) { + return 0; + } + } + return 1; + } + return 0; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c new file mode 100644 index 0000000..d148872 --- /dev/null +++ b/win/tclWinConsole.c @@ -0,0 +1,1427 @@ +/* + * tclWinConsole.c -- + * + * This file implements the Windows-specific console functions, and the + * "console" channel driver. + * + * Copyright (c) 1999 by Scriptics Corp. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tclWinInt.h" + +/* + * The following variable is used to tell whether this module has been + * initialized. + */ + +static int initialized = 0; + +/* + * The consoleMutex locks around access to the initialized variable, and it is + * used to protect background threads from being terminated while they are + * using APIs that hold locks. + */ + +TCL_DECLARE_MUTEX(consoleMutex) + +/* + * Bit masks used in the flags field of the ConsoleInfo structure below. + */ + +#define CONSOLE_PENDING (1<<0) /* Message is pending in the queue. */ +#define CONSOLE_ASYNC (1<<1) /* Channel is non-blocking. */ + +/* + * Bit masks used in the sharedFlags field of the ConsoleInfo structure below. + */ + +#define CONSOLE_EOF (1<<2) /* Console has reached EOF. */ +#define CONSOLE_BUFFERED (1<<3) /* Data was read into a buffer by the reader + * thread. */ + +#define CONSOLE_BUFFER_SIZE (8*1024) + +/* + * Structure containing handles associated with one of the special console + * threads. + */ + +typedef struct { + 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. + */ + +typedef struct ConsoleInfo { + HANDLE handle; + int type; + struct ConsoleInfo *nextPtr;/* Pointer to next registered console. */ + Tcl_Channel channel; /* Pointer to channel structure. */ + int validMask; /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, or TCL_EXCEPTION: indicates + * which operations are valid on the file. */ + int watchMask; /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, or TCL_EXCEPTION: indicates + * which events should be reported. */ + int flags; /* State flags, see above for a list. */ + Tcl_ThreadId threadId; /* Thread to which events should be reported. + * This value is used by the reader/writer + * threads. */ + ConsoleThreadInfo writer; /* A specialized thread for handling + * asynchronous writes to the console; the + * waiting starts when a 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 + * writer thread so access must be + * synchronized with the writable object. */ + char *writeBuf; /* Current background output buffer. Access is + * synchronized with the writable object. */ + int writeBufLen; /* Size of write buffer. Access is + * synchronized with the writable object. */ + int toWrite; /* Current amount to be written. Access is + * synchronized with the writable object. */ + 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. */ + char buffer[CONSOLE_BUFFER_SIZE]; + /* Data consumed by reader thread. */ +} ConsoleInfo; + +typedef struct { + /* + * The following pointer refers to the head of the list of consoles that + * are being watched for file events. + */ + + ConsoleInfo *firstConsolePtr; +} ThreadSpecificData; + +static Tcl_ThreadDataKey dataKey; + +/* + * The following structure is what is added to the Tcl event queue when + * console events are generated. + */ + +typedef struct { + Tcl_Event header; /* Information that is standard for all + * events. */ + ConsoleInfo *infoPtr; /* Pointer to console info structure. Note + * that we still have to verify that the + * console exists before dereferencing this + * pointer. */ +} ConsoleEvent; + +/* + * Declarations for functions used only in this file. + */ + +static int ConsoleBlockModeProc(ClientData instanceData, + int mode); +static void ConsoleCheckProc(ClientData clientData, int flags); +static int ConsoleCloseProc(ClientData instanceData, + Tcl_Interp *interp); +static int ConsoleEventProc(Tcl_Event *evPtr, int flags); +static void ConsoleExitHandler(ClientData clientData); +static int ConsoleGetHandleProc(ClientData instanceData, + int direction, ClientData *handlePtr); +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); +static DWORD WINAPI ConsoleReaderThread(LPVOID arg); +static void ConsoleSetupProc(ClientData clientData, int flags); +static void ConsoleWatchProc(ClientData instanceData, int mask); +static DWORD WINAPI ConsoleWriterThread(LPVOID arg); +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 const Tcl_ChannelType consoleChannelType = { + "console", /* Type name. */ + TCL_CHANNEL_VERSION_5, /* v5 channel */ + ConsoleCloseProc, /* Close proc. */ + ConsoleInputProc, /* Input proc. */ + ConsoleOutputProc, /* Output proc. */ + NULL, /* Seek proc. */ + NULL, /* Set option proc. */ + NULL, /* Get option proc. */ + ConsoleWatchProc, /* Set up notifier to watch the channel. */ + ConsoleGetHandleProc, /* Get an OS handle from channel. */ + NULL, /* close2proc. */ + ConsoleBlockModeProc, /* Set blocking or non-blocking mode. */ + NULL, /* Flush proc. */ + NULL, /* Handler proc. */ + NULL, /* Wide seek proc. */ + ConsoleThreadActionProc, /* Thread action proc. */ + NULL /* Truncation proc. */ +}; + +/* + *---------------------------------------------------------------------- + * + * ReadConsoleBytes, WriteConsoleBytes -- + * + * Wrapper for ReadConsole{A,W}, that takes and returns number of bytes + * instead of number of TCHARS. + * + *---------------------------------------------------------------------- + */ + +static BOOL +ReadConsoleBytes( + HANDLE hConsole, + LPVOID lpBuffer, + DWORD nbytes, + LPDWORD nbytesread) +{ + DWORD ntchars; + BOOL result; + int tcharsize = sizeof(TCHAR); + + /* + * If user types a Ctrl-Break or Ctrl-C, ReadConsole will return + * success with ntchars == 0 and GetLastError() will be + * ERROR_OPERATION_ABORTED. We do not want to treat this case + * as EOF so we will loop around again. If no Ctrl signal handlers + * have been established, the default signal OS handler in a separate + * thread will terminate the program. If a Ctrl signal handler + * has been established (through an extension for example), it + * will run and take whatever action it deems appropriate. + */ + do { + result = ReadConsole(hConsole, lpBuffer, nbytes / tcharsize, &ntchars, + NULL); + } while (result && ntchars == 0 && GetLastError() == ERROR_OPERATION_ABORTED); + if (nbytesread != NULL) { + *nbytesread = ntchars * tcharsize; + } + return result; +} + +static BOOL +WriteConsoleBytes( + HANDLE hConsole, + const void *lpBuffer, + DWORD nbytes, + LPDWORD nbyteswritten) +{ + DWORD ntchars; + BOOL result; + int tcharsize = sizeof(TCHAR); + + result = WriteConsole(hConsole, lpBuffer, nbytes / tcharsize, &ntchars, + NULL); + if (nbyteswritten != NULL) { + *nbyteswritten = ntchars * tcharsize; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * ConsoleInit -- + * + * This function initializes the static variables for this file. + * + * Results: + * None. + * + * Side effects: + * Creates a new event source. + * + *---------------------------------------------------------------------- + */ + +static void +ConsoleInit(void) +{ + /* + * Check the initialized flag first, then check again in the mutex. This + * is a speed enhancement. + */ + + if (!initialized) { + Tcl_MutexLock(&consoleMutex); + if (!initialized) { + initialized = 1; + Tcl_CreateExitHandler(ProcExitHandler, NULL); + } + Tcl_MutexUnlock(&consoleMutex); + } + + if (TclThreadDataKeyGet(&dataKey) == NULL) { + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + tsdPtr->firstConsolePtr = NULL; + Tcl_CreateEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL); + Tcl_CreateThreadExitHandler(ConsoleExitHandler, NULL); + } +} + +/* + *---------------------------------------------------------------------- + * + * ConsoleExitHandler -- + * + * This function is called to cleanup the console module before Tcl is + * unloaded. + * + * Results: + * None. + * + * Side effects: + * Removes the console event source. + * + *---------------------------------------------------------------------- + */ + +static void +ConsoleExitHandler( + ClientData clientData) /* Old window proc. */ +{ + Tcl_DeleteEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL); +} + +/* + *---------------------------------------------------------------------- + * + * ProcExitHandler -- + * + * This function is called to cleanup the process list before Tcl is + * unloaded. + * + * Results: + * None. + * + * Side effects: + * Resets the process list. + * + *---------------------------------------------------------------------- + */ + +static void +ProcExitHandler( + ClientData clientData) /* Old window proc. */ +{ + Tcl_MutexLock(&consoleMutex); + initialized = 0; + Tcl_MutexUnlock(&consoleMutex); +} + +/* + *---------------------------------------------------------------------- + * + * ConsoleSetupProc -- + * + * This procedure is invoked before Tcl_DoOneEvent blocks waiting for an + * event. + * + * Results: + * None. + * + * Side effects: + * Adjusts the block time if needed. + * + *---------------------------------------------------------------------- + */ + +void +ConsoleSetupProc( + ClientData data, /* Not used. */ + int flags) /* Event flags as passed to Tcl_DoOneEvent. */ +{ + ConsoleInfo *infoPtr; + Tcl_Time blockTime = { 0, 0 }; + int block = 1; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if (!(flags & TCL_FILE_EVENTS)) { + return; + } + + /* + * Look to see if any events are already pending. If they are, poll. + */ + + for (infoPtr = tsdPtr->firstConsolePtr; infoPtr != NULL; + infoPtr = infoPtr->nextPtr) { + if (infoPtr->watchMask & TCL_WRITABLE) { + if (WaitForSingleObject(infoPtr->writer.readyEvent, + 0) != WAIT_TIMEOUT) { + block = 0; + } + } + if (infoPtr->watchMask & TCL_READABLE) { + if (WaitForRead(infoPtr, 0) >= 0) { + block = 0; + } + } + } + if (!block) { + Tcl_SetMaxBlockTime(&blockTime); + } +} + +/* + *---------------------------------------------------------------------- + * + * ConsoleCheckProc -- + * + * This procedure is called by Tcl_DoOneEvent to check the console event + * source for events. + * + * Results: + * None. + * + * Side effects: + * May queue an event. + * + *---------------------------------------------------------------------- + */ + +static void +ConsoleCheckProc( + ClientData data, /* Not used. */ + int flags) /* Event flags as passed to Tcl_DoOneEvent. */ +{ + ConsoleInfo *infoPtr; + int needEvent; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if (!(flags & TCL_FILE_EVENTS)) { + return; + } + + /* + * Queue events for any ready consoles that don't already have events + * queued. + */ + + for (infoPtr = tsdPtr->firstConsolePtr; infoPtr != NULL; + infoPtr = infoPtr->nextPtr) { + if (infoPtr->flags & CONSOLE_PENDING) { + continue; + } + + /* + * Queue an event if the console is signaled for reading or writing. + */ + + needEvent = 0; + if (infoPtr->watchMask & TCL_WRITABLE) { + if (WaitForSingleObject(infoPtr->writer.readyEvent, + 0) != WAIT_TIMEOUT) { + needEvent = 1; + } + } + + if (infoPtr->watchMask & TCL_READABLE) { + if (WaitForRead(infoPtr, 0) >= 0) { + needEvent = 1; + } + } + + if (needEvent) { + ConsoleEvent *evPtr = ckalloc(sizeof(ConsoleEvent)); + + infoPtr->flags |= CONSOLE_PENDING; + evPtr->header.proc = ConsoleEventProc; + evPtr->infoPtr = infoPtr; + Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * ConsoleBlockModeProc -- + * + * Set blocking or non-blocking mode on channel. + * + * Results: + * 0 if successful, errno when failed. + * + * Side effects: + * Sets the device into blocking or non-blocking mode. + * + *---------------------------------------------------------------------- + */ + +static int +ConsoleBlockModeProc( + ClientData instanceData, /* Instance data for channel. */ + int mode) /* TCL_MODE_BLOCKING or + * TCL_MODE_NONBLOCKING. */ +{ + ConsoleInfo *infoPtr = instanceData; + + /* + * Consoles on Windows can not be switched between blocking and + * nonblocking, hence we have to emulate the behavior. This is done in the + * input function by checking against a bit in the state. We set or unset + * the bit here to cause the input function to emulate the correct + * behavior. + */ + + if (mode == TCL_MODE_NONBLOCKING) { + infoPtr->flags |= CONSOLE_ASYNC; + } else { + infoPtr->flags &= ~CONSOLE_ASYNC; + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * ConsoleCloseProc -- + * + * Closes a console based IO channel. + * + * Results: + * 0 on success, errno otherwise. + * + * Side effects: + * Closes the physical channel. + * + *---------------------------------------------------------------------- + */ + +static int +ConsoleCloseProc( + ClientData instanceData, /* Pointer to ConsoleInfo structure. */ + Tcl_Interp *interp) /* For error reporting. */ +{ + ConsoleInfo *consolePtr = instanceData; + int errorCode = 0; + ConsoleInfo *infoPtr, **nextPtrPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + /* + * 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 + * trying to read from the console. + */ + + 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; + + /* + * Wait for the writer thread to finish the current buffer, then terminate + * the thread and close the handles. If the channel is nonblocking, there + * should be no pending write operations. + */ + + if (consolePtr->writer.thread) { + if (consolePtr->toWrite) { + /* + * We only need to wait if there is something to write. This may + * prevent infinite wait on exit. [Python Bug 216289] + */ + + WaitForSingleObject(consolePtr->writer.readyEvent, 5000); + } + + 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 + * another. + */ + + if (!TclInThreadExit() + || ((GetStdHandle(STD_INPUT_HANDLE) != consolePtr->handle) + && (GetStdHandle(STD_OUTPUT_HANDLE) != consolePtr->handle) + && (GetStdHandle(STD_ERROR_HANDLE) != consolePtr->handle))) { + if (CloseHandle(consolePtr->handle) == FALSE) { + TclWinConvertError(GetLastError()); + errorCode = errno; + } + } + + consolePtr->watchMask &= consolePtr->validMask; + + /* + * Remove the file from the list of watched files. + */ + + for (nextPtrPtr = &(tsdPtr->firstConsolePtr), infoPtr = *nextPtrPtr; + infoPtr != NULL; + nextPtrPtr = &infoPtr->nextPtr, infoPtr = *nextPtrPtr) { + if (infoPtr == (ConsoleInfo *) consolePtr) { + *nextPtrPtr = infoPtr->nextPtr; + break; + } + } + if (consolePtr->writeBuf != NULL) { + ckfree(consolePtr->writeBuf); + consolePtr->writeBuf = 0; + } + ckfree(consolePtr); + + return errorCode; +} + +/* + *---------------------------------------------------------------------- + * + * ConsoleInputProc -- + * + * Reads input from the IO channel into the buffer given. Returns count + * of how many bytes were actually read, and an error indication. + * + * Results: + * A count of how many bytes were read is returned and an error + * indication is returned in an output argument. + * + * Side effects: + * Reads input from the actual channel. + * + *---------------------------------------------------------------------- + */ + +static int +ConsoleInputProc( + ClientData instanceData, /* Console state. */ + char *buf, /* Where to store data read. */ + int bufSize, /* How much space is available in the + * buffer? */ + int *errorCode) /* Where to store error code. */ +{ + ConsoleInfo *infoPtr = instanceData; + DWORD count, bytesRead = 0; + int result; + + *errorCode = 0; + + /* + * Synchronize with the reader thread. + */ + + result = WaitForRead(infoPtr, (infoPtr->flags & CONSOLE_ASYNC) ? 0 : 1); + + /* + * If an error occurred, return immediately. + */ + + if (result == -1) { + *errorCode = errno; + return -1; + } + + if (infoPtr->readFlags & CONSOLE_BUFFERED) { + /* + * Data is stored in the buffer. + */ + + if (bufSize < (infoPtr->bytesRead - infoPtr->offset)) { + memcpy(buf, &infoPtr->buffer[infoPtr->offset], (size_t) bufSize); + bytesRead = bufSize; + infoPtr->offset += bufSize; + } else { + memcpy(buf, &infoPtr->buffer[infoPtr->offset], (size_t) bufSize); + bytesRead = infoPtr->bytesRead - infoPtr->offset; + + /* + * Reset the buffer. + */ + + infoPtr->readFlags &= ~CONSOLE_BUFFERED; + infoPtr->offset = 0; + } + + return bytesRead; + } + + /* + * Attempt to read bufSize bytes. The read will return immediately if + * there is any data available. Otherwise it will block until at least one + * byte is available or an EOF occurs. + */ + + if (ReadConsoleBytes(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize, + &count) == TRUE) { + /* + * TODO: This potentially writes beyond the limits specified + * by the caller. In practice this is harmless, since all writes + * are into ChannelBuffers, and those have padding, but still + * ought to remove this, unless some Windows wizard can give + * a reason not to. + */ + buf[count] = '\0'; + return count; + } + + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * ConsoleOutputProc -- + * + * Writes the given output on the IO channel. Returns count of how many + * characters were actually written, and an error indication. + * + * Results: + * A count of how many characters were written is returned and an error + * indication is returned in an output argument. + * + * Side effects: + * Writes output on the actual channel. + * + *---------------------------------------------------------------------- + */ + +static int +ConsoleOutputProc( + ClientData instanceData, /* Console state. */ + const char *buf, /* The data buffer. */ + int toWrite, /* How many bytes to write? */ + int *errorCode) /* Where to store error code. */ +{ + ConsoleInfo *infoPtr = instanceData; + ConsoleThreadInfo *threadInfo = &infoPtr->writer; + DWORD bytesWritten, timeout; + + *errorCode = 0; + + /* 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 = EWOULDBLOCK; + goto error; + } + + /* + * Check for a background error on the last write. + */ + + if (infoPtr->writeError) { + TclWinConvertError(infoPtr->writeError); + infoPtr->writeError = 0; + goto error; + } + + if (infoPtr->flags & CONSOLE_ASYNC) { + /* + * The console is non-blocking, so copy the data into the output + * buffer and restart the writer thread. + */ + + if (toWrite > infoPtr->writeBufLen) { + /* + * Reallocate the buffer to be large enough to hold the data. + */ + + if (infoPtr->writeBuf) { + ckfree(infoPtr->writeBuf); + } + infoPtr->writeBufLen = toWrite; + infoPtr->writeBuf = ckalloc(toWrite); + } + memcpy(infoPtr->writeBuf, buf, (size_t) toWrite); + infoPtr->toWrite = toWrite; + ResetEvent(threadInfo->readyEvent); + TclPipeThreadSignal(&threadInfo->TI); + bytesWritten = toWrite; + } else { + /* + * In the blocking case, just try to write the buffer directly. This + * avoids an unnecessary copy. + */ + + if (WriteConsoleBytes(infoPtr->handle, buf, (DWORD) toWrite, + &bytesWritten) == FALSE) { + TclWinConvertError(GetLastError()); + goto error; + } + } + return bytesWritten; + + error: + *errorCode = errno; + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * ConsoleEventProc -- + * + * This function is invoked by Tcl_ServiceEvent when a file event reaches + * the front of the event queue. This procedure invokes Tcl_NotifyChannel + * on the console. + * + * 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. + * + * Side effects: + * Whatever the notifier callback does. + * + *---------------------------------------------------------------------- + */ + +static int +ConsoleEventProc( + Tcl_Event *evPtr, /* Event to service. */ + int flags) /* Flags that indicate what events to handle, + * such as TCL_FILE_EVENTS. */ +{ + ConsoleEvent *consoleEvPtr = (ConsoleEvent *) evPtr; + ConsoleInfo *infoPtr; + int mask; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if (!(flags & TCL_FILE_EVENTS)) { + return 0; + } + + /* + * Search through the list of watched consoles for the one whose handle + * matches the event. We do this rather than simply dereferencing the + * handle in the event so that consoles can be deleted while the event is + * in the queue. + */ + + for (infoPtr = tsdPtr->firstConsolePtr; infoPtr != NULL; + infoPtr = infoPtr->nextPtr) { + if (consoleEvPtr->infoPtr == infoPtr) { + infoPtr->flags &= ~CONSOLE_PENDING; + break; + } + } + + /* + * Remove stale events. + */ + + if (!infoPtr) { + return 1; + } + + /* + * Check to see if the console is readable. Note that we can't tell if a + * console is writable, so we always report it as being writable unless we + * have detected EOF. + */ + + mask = 0; + if (infoPtr->watchMask & TCL_WRITABLE) { + if (WaitForSingleObject(infoPtr->writer.readyEvent, + 0) != WAIT_TIMEOUT) { + mask = TCL_WRITABLE; + } + } + + if (infoPtr->watchMask & TCL_READABLE) { + if (WaitForRead(infoPtr, 0) >= 0) { + if (infoPtr->readFlags & CONSOLE_EOF) { + mask = TCL_READABLE; + } else { + mask |= TCL_READABLE; + } + } + } + + /* + * Inform the channel of the events. + */ + + Tcl_NotifyChannel(infoPtr->channel, infoPtr->watchMask & mask); + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * ConsoleWatchProc -- + * + * Called by the notifier to set up to watch for events on this channel. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +ConsoleWatchProc( + ClientData instanceData, /* Console state. */ + int mask) /* What events to watch for, OR-ed combination + * of TCL_READABLE, TCL_WRITABLE and + * TCL_EXCEPTION. */ +{ + ConsoleInfo **nextPtrPtr, *ptr; + ConsoleInfo *infoPtr = instanceData; + int oldMask = infoPtr->watchMask; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + /* + * Since most of the work is handled by the background threads, we just + * need to update the watchMask and then force the notifier to poll once. + */ + + infoPtr->watchMask = mask & infoPtr->validMask; + if (infoPtr->watchMask) { + Tcl_Time blockTime = { 0, 0 }; + + if (!oldMask) { + infoPtr->nextPtr = tsdPtr->firstConsolePtr; + tsdPtr->firstConsolePtr = infoPtr; + } + Tcl_SetMaxBlockTime(&blockTime); + } else if (oldMask) { + /* + * Remove the console from the list of watched consoles. + */ + + for (nextPtrPtr = &(tsdPtr->firstConsolePtr), ptr = *nextPtrPtr; + ptr != NULL; + nextPtrPtr = &ptr->nextPtr, ptr = *nextPtrPtr) { + if (infoPtr == ptr) { + *nextPtrPtr = ptr->nextPtr; + break; + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * ConsoleGetHandleProc -- + * + * Called from Tcl_GetChannelHandle to retrieve OS handles from inside a + * command consoleline 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. + * + *---------------------------------------------------------------------- + */ + +static int +ConsoleGetHandleProc( + ClientData instanceData, /* The console state. */ + int direction, /* TCL_READABLE or TCL_WRITABLE. */ + ClientData *handlePtr) /* Where to store the handle. */ +{ + ConsoleInfo *infoPtr = instanceData; + + *handlePtr = infoPtr->handle; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * WaitForRead -- + * + * Wait until some data is available, the console is at EOF or the reader + * thread is blocked waiting for data (if the channel is in non-blocking + * mode). + * + * Results: + * Returns 1 if console is readable. Returns 0 if there is no data on the + * console, but there is buffered data. Returns -1 if an error occurred. + * If an error occurred, the threads may not be synchronized. + * + * Side effects: + * Updates the shared state flags. If no error occurred, the reader + * thread is blocked waiting for a signal from the main thread. + * + *---------------------------------------------------------------------- + */ + +static int +WaitForRead( + ConsoleInfo *infoPtr, /* Console state. */ + int blocking) /* Indicates whether call should be blocking + * or not. */ +{ + DWORD timeout, count; + HANDLE *handle = infoPtr->handle; + ConsoleThreadInfo *threadInfo = &infoPtr->reader; + INPUT_RECORD input; + + while (1) { + /* + * Synchronize with the reader thread. + */ + + /* 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 = EWOULDBLOCK; + return -1; + } + + /* + * At this point, the two threads are synchronized, so it is safe to + * access shared state. + */ + + /* + * If the console has hit EOF, it is always readable. + */ + + if (infoPtr->readFlags & CONSOLE_EOF) { + return 1; + } + + if (PeekConsoleInput(handle, &input, 1, &count) == FALSE) { + /* + * Check to see if the peek failed because of EOF. + */ + + TclWinConvertError(GetLastError()); + + if (errno == EOF) { + infoPtr->readFlags |= CONSOLE_EOF; + return 1; + } + + /* + * Ignore errors if there is data in the buffer. + */ + + if (infoPtr->readFlags & CONSOLE_BUFFERED) { + return 0; + } else { + return -1; + } + } + + /* + * If there is data in the buffer, the console must be readable (since + * it is a line-oriented device). + */ + + if (infoPtr->readFlags & CONSOLE_BUFFERED) { + return 1; + } + + /* + * There wasn't any data available, so reset the thread and try again. + */ + + ResetEvent(threadInfo->readyEvent); + TclPipeThreadSignal(&threadInfo->TI); + } +} + +/* + *---------------------------------------------------------------------- + * + * ConsoleReaderThread -- + * + * This function runs in a separate thread and waits for input to become + * available on a console. + * + * Results: + * None. + * + * Side effects: + * Signals the main thread when input become available. May cause the + * main thread to wake up by posting a message. May one line from the + * console for each wait operation. + * + *---------------------------------------------------------------------- + */ + +static DWORD WINAPI +ConsoleReaderThread( + LPVOID arg) +{ + TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *)arg; + ConsoleInfo *infoPtr = NULL; /* access info only after success init/wait */ + HANDLE *handle = NULL; + ConsoleThreadInfo *threadInfo = NULL; + int done = 0; + + while (!done) { + /* + * Wait for the main thread to signal before attempting to read. + */ + + 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, + (LPDWORD) &infoPtr->bytesRead) != FALSE) { + /* + * Data was stored in the buffer. + */ + + infoPtr->readFlags |= CONSOLE_BUFFERED; + } else { + DWORD err = GetLastError(); + + if (err == (DWORD) EOF) { + infoPtr->readFlags = CONSOLE_EOF; + } + done = 1; + } + + /* + * Signal the main thread by signalling the readable event and then + * waking up the notifier thread. + */ + + SetEvent(threadInfo->readyEvent); + + /* + * Alert the foreground thread. Note that we need to treat this like a + * critical section so the foreground thread does not terminate this + * thread while we are holding a mutex in the notifier code. + */ + + Tcl_MutexLock(&consoleMutex); + if (infoPtr->threadId != NULL) { + /* + * 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; +} + +/* + *---------------------------------------------------------------------- + * + * ConsoleWriterThread -- + * + * This function runs in a separate thread and writes data onto a + * console. + * + * Results: + * Always returns 0. + * + * Side effects: + + * Signals the main thread when an output operation is completed. May + * cause the main thread to wake up by posting a message. + * + *---------------------------------------------------------------------- + */ + +static DWORD WINAPI +ConsoleWriterThread( + LPVOID arg) +{ + 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; + int done = 0; + + while (!done) { + /* + * Wait for the main thread to signal before attempting to write. + */ + if (!TclPipeThreadWaitForSignal(&pipeTI)) { + /* exit */ + break; + } + if (!infoPtr) { + infoPtr = (ConsoleInfo *)pipeTI->clientData; + handle = infoPtr->handle; + threadInfo = &infoPtr->writer; + } + + buf = infoPtr->writeBuf; + toWrite = infoPtr->toWrite; + + /* + * Loop until all of the bytes are written or an error occurs. + */ + + while (toWrite > 0) { + if (WriteConsoleBytes(handle, buf, (DWORD) toWrite, + &count) == FALSE) { + infoPtr->writeError = GetLastError(); + done = 1; + break; + } + toWrite -= count; + buf += count; + } + + /* + * Signal the main thread by signalling the writable event and then + * waking up the notifier thread. + */ + + SetEvent(threadInfo->readyEvent); + + /* + * Alert the foreground thread. Note that we need to treat this like a + * critical section so the foreground thread does not terminate this + * thread while we are holding a mutex in the notifier code. + */ + + Tcl_MutexLock(&consoleMutex); + if (infoPtr->threadId != NULL) { + /* + * 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; +} + +/* + *---------------------------------------------------------------------- + * + * TclWinOpenConsoleChannel -- + * + * Constructs a Console channel for the specified standard OS handle. + * This is a helper function to break up the construction of channels + * into File, Console, or Serial. + * + * Results: + * Returns the new channel, or NULL. + * + * Side effects: + * May open the channel. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +TclWinOpenConsoleChannel( + HANDLE handle, + char *channelName, + int permissions) +{ + char encoding[4 + TCL_INTEGER_SPACE]; + ConsoleInfo *infoPtr; + DWORD modes; + + ConsoleInit(); + + /* + * See if a channel with this handle already exists. + */ + + infoPtr = ckalloc(sizeof(ConsoleInfo)); + memset(infoPtr, 0, sizeof(ConsoleInfo)); + + infoPtr->validMask = permissions; + infoPtr->handle = handle; + infoPtr->channel = (Tcl_Channel) NULL; + + wsprintfA(encoding, "cp%d", GetConsoleCP()); + + infoPtr->threadId = Tcl_GetCurrentThread(); + + /* + * Use the pointer for the name of the result channel. This keeps the + * channel names unique, since some may share handles (stdin/stdout/stderr + * for instance). + */ + + sprintf(channelName, "file%" TCL_I_MODIFIER "x", (size_t) infoPtr); + + infoPtr->channel = Tcl_CreateChannel(&consoleChannelType, channelName, + infoPtr, permissions); + + if (permissions & TCL_READABLE) { + /* + * Make sure the console input buffer is ready for only character + * input notifications and the buffer is set for line buffering. IOW, + * we only want to catch when complete lines are ready for reading. + */ + + GetConsoleMode(infoPtr->handle, &modes); + modes &= ~(ENABLE_WINDOW_INPUT | ENABLE_MOUSE_INPUT); + modes |= ENABLE_LINE_INPUT; + SetConsoleMode(infoPtr->handle, modes); + + 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->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); + } + + /* + * Files have default translation of AUTO and ^Z eof char, which means + * that a ^Z will be accepted as EOF when reading. + */ + + Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto"); + Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}"); +#ifdef UNICODE + Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", "unicode"); +#else + Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", encoding); +#endif + return infoPtr->channel; +} + +/* + *---------------------------------------------------------------------- + * + * ConsoleThreadActionProc -- + * + * Insert or remove any thread local refs to this channel. + * + * Results: + * None. + * + * Side effects: + * Changes thread local list of valid channels. + * + *---------------------------------------------------------------------- + */ + +static void +ConsoleThreadActionProc( + ClientData instanceData, + int action) +{ + ConsoleInfo *infoPtr = instanceData; + + /* + * 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. + */ + + Tcl_MutexLock(&consoleMutex); + if (action == TCL_CHANNEL_THREAD_INSERT) { + /* + * We can't copy the thread information from the channel when the + * channel is created. At this time the channel back pointer has not + * been set yet. However in that case the threadId has already been + * set by TclpCreateCommandChannel itself, so the structure is still + * good. + */ + + ConsoleInit(); + if (infoPtr->channel != NULL) { + infoPtr->threadId = Tcl_GetChannelThread(infoPtr->channel); + } + } else { + infoPtr->threadId = NULL; + } + Tcl_MutexUnlock(&consoleMutex); +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/win/tclWinDde.c b/win/tclWinDde.c new file mode 100644 index 0000000..2589630 --- /dev/null +++ b/win/tclWinDde.c @@ -0,0 +1,1888 @@ +/* + * tclWinDde.c -- + * + * This file provides functions that implement the "send" command, + * allowing commands to be passed from interpreter to interpreter. + * + * Copyright (c) 1997 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. + */ + +#undef STATIC_BUILD +#ifndef USE_TCL_STUBS +# define USE_TCL_STUBS +#endif +#include "tclInt.h" +#include <dde.h> +#include <ddeml.h> + +#ifndef UNICODE +# undef CP_WINUNICODE +# define CP_WINUNICODE CP_WINANSI +# undef Tcl_WinTCharToUtf +# define Tcl_WinTCharToUtf(a,b,c) Tcl_ExternalToUtfDString(NULL,a,b,c) +# undef Tcl_WinUtfToTChar +# define Tcl_WinUtfToTChar(a,b,c) Tcl_UtfToExternalDString(NULL,a,b,c) +#endif + +#if !defined(NDEBUG) + /* test POKE server Implemented for debug mode only */ +# undef CBF_FAIL_POKES +# define CBF_FAIL_POKES 0 +#endif + +/* + * The following structure is used to keep track of the interpreters + * registered by this process. + */ + +typedef struct RegisteredInterp { + struct RegisteredInterp *nextPtr; + /* The next interp this application knows + * about. */ + TCHAR *name; /* Interpreter's name (malloc-ed). */ + Tcl_Obj *handlerPtr; /* The server handler command */ + Tcl_Interp *interp; /* The interpreter attached to this name. */ +} RegisteredInterp; + +/* + * Used to keep track of conversations. + */ + +typedef struct Conversation { + struct Conversation *nextPtr; + /* The next conversation in the list. */ + RegisteredInterp *riPtr; /* The info we know about the conversation. */ + HCONV hConv; /* The DDE handle for this conversation. */ + Tcl_Obj *returnPackagePtr; /* The result package for this conversation. */ +} Conversation; + +struct DdeEnumServices { + Tcl_Interp *interp; + int result; + ATOM service; + ATOM topic; + HWND hwnd; +}; + +typedef struct { + Conversation *currentConversations; + /* A list of conversations currently being + * processed. */ + RegisteredInterp *interpListPtr; + /* List of all interpreters registered in the + * current process. */ +} ThreadSpecificData; +static Tcl_ThreadDataKey dataKey; + +/* + * The following variables cannot be placed in thread-local storage. The Mutex + * ddeMutex guards access to the ddeInstance. + */ + +static HSZ ddeServiceGlobal = 0; +static DWORD ddeInstance; /* The application instance handle given to us + * by DdeInitialize. */ +static int ddeIsServer = 0; + +#define TCL_DDE_VERSION "1.4.0" +#define TCL_DDE_PACKAGE_NAME "dde" +#define TCL_DDE_SERVICE_NAME TEXT("TclEval") +#define TCL_DDE_EXECUTE_RESULT TEXT("$TCLEVAL$EXECUTE$RESULT") + +#define DDE_FLAG_ASYNC 1 +#define DDE_FLAG_BINARY 2 +#define DDE_FLAG_FORCE 4 + +TCL_DECLARE_MUTEX(ddeMutex) + +/* + * Forward declarations for functions defined later in this file. + */ + +static LRESULT CALLBACK DdeClientWindowProc(HWND hwnd, UINT uMsg, + WPARAM wParam, LPARAM lParam); +static int DdeCreateClient(struct DdeEnumServices *es); +static BOOL CALLBACK DdeEnumWindowsCallback(HWND hwndTarget, + LPARAM lParam); +static void DdeExitProc(ClientData clientData); +static int DdeGetServicesList(Tcl_Interp *interp, + const TCHAR *serviceName, const TCHAR *topicName); +static HDDEDATA CALLBACK DdeServerProc(UINT uType, UINT uFmt, HCONV hConv, + HSZ ddeTopic, HSZ ddeItem, HDDEDATA hData, + DWORD dwData1, DWORD dwData2); +static LRESULT DdeServicesOnAck(HWND hwnd, WPARAM wParam, + LPARAM lParam); +static void DeleteProc(ClientData clientData); +static Tcl_Obj * ExecuteRemoteObject(RegisteredInterp *riPtr, + Tcl_Obj *ddeObjectPtr); +static int MakeDdeConnection(Tcl_Interp *interp, + const TCHAR *name, HCONV *ddeConvPtr); +static void SetDdeError(Tcl_Interp *interp); +static int DdeObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); + +DLLEXPORT int Dde_Init(Tcl_Interp *interp); +DLLEXPORT int Dde_SafeInit(Tcl_Interp *interp); + +/* + *---------------------------------------------------------------------- + * + * Dde_Init -- + * + * This function initializes the dde command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Dde_Init( + Tcl_Interp *interp) +{ + if (!Tcl_InitStubs(interp, "8.1", 0)) { + return TCL_ERROR; + } + +#ifdef UNICODE + if (TclWinGetPlatformId() < VER_PLATFORM_WIN32_NT) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "Win32s and Windows 9x are not supported platforms", -1)); + return TCL_ERROR; + } +#endif + Tcl_CreateObjCommand(interp, "dde", DdeObjCmd, NULL, NULL); + Tcl_CreateExitHandler(DdeExitProc, NULL); + return Tcl_PkgProvide(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION); +} + +/* + *---------------------------------------------------------------------- + * + * Dde_SafeInit -- + * + * This function initializes the dde command within a safe interp + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Dde_SafeInit( + Tcl_Interp *interp) +{ + int result = Dde_Init(interp); + if (result == TCL_OK) { + Tcl_HideCommand(interp, "dde", "dde"); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Initialize -- + * + * Initialize the global DDE instance. + * + * Results: + * None. + * + * Side effects: + * Registers the DDE server proc. + * + *---------------------------------------------------------------------- + */ + +static void +Initialize(void) +{ + int nameFound = 0; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + /* + * See if the application is already registered; if so, remove its current + * name from the registry. The deletion of the command will take care of + * disposing of this entry. + */ + + if (tsdPtr->interpListPtr != NULL) { + nameFound = 1; + } + + /* + * Make sure that the DDE server is there. This is done only once, add an + * exit handler tear it down. + */ + + if (ddeInstance == 0) { + Tcl_MutexLock(&ddeMutex); + if (ddeInstance == 0) { + if (DdeInitialize(&ddeInstance, (PFNCALLBACK) DdeServerProc, + CBF_SKIP_REGISTRATIONS | CBF_SKIP_UNREGISTRATIONS + | CBF_FAIL_POKES, 0) != DMLERR_NO_ERROR) { + ddeInstance = 0; + } + } + Tcl_MutexUnlock(&ddeMutex); + } + if ((ddeServiceGlobal == 0) && (nameFound != 0)) { + Tcl_MutexLock(&ddeMutex); + if ((ddeServiceGlobal == 0) && (nameFound != 0)) { + ddeIsServer = 1; + Tcl_CreateExitHandler(DdeExitProc, NULL); + ddeServiceGlobal = DdeCreateStringHandle(ddeInstance, + TCL_DDE_SERVICE_NAME, CP_WINUNICODE); + DdeNameService(ddeInstance, ddeServiceGlobal, 0L, DNS_REGISTER); + } else { + ddeIsServer = 0; + } + Tcl_MutexUnlock(&ddeMutex); + } +} + +/* + *---------------------------------------------------------------------- + * + * DdeSetServerName -- + * + * This function is called to associate an ASCII name with a Dde server. + * If the interpreter has already been named, the name replaces the old + * one. + * + * Results: + * The return value is the name actually given to the interp. This will + * normally be the same as name, but if name was already in use for a Dde + * Server then a name of the form "name #2" will be chosen, with a high + * enough number to make the name unique. + * + * Side effects: + * Registration info is saved, thereby allowing the "send" command to be + * used later to invoke commands in the application. In addition, the + * "send" command is created in the application's interpreter. The + * registration will be removed automatically if the interpreter is + * deleted or the "send" command is removed. + * + *---------------------------------------------------------------------- + */ + +static const TCHAR * +DdeSetServerName( + Tcl_Interp *interp, + const TCHAR *name, /* The name that will be used to refer to the + * interpreter in later "send" commands. Must + * be globally unique. */ + int flags, /* DDE_FLAG_FORCE or 0 */ + Tcl_Obj *handlerPtr) /* Name of the optional proc/command to handle + * incoming Dde eval's */ +{ + int suffix, offset; + RegisteredInterp *riPtr, *prevPtr; + Tcl_DString dString; + const TCHAR *actualName; + Tcl_Obj *srvListPtr = NULL, **srvPtrPtr = NULL; + int n, srvCount = 0, lastSuffix, r = TCL_OK; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + /* + * See if the application is already registered; if so, remove its current + * name from the registry. The deletion of the command will take care of + * disposing of this entry. + */ + + for (riPtr = tsdPtr->interpListPtr, prevPtr = NULL; riPtr != NULL; + prevPtr = riPtr, riPtr = riPtr->nextPtr) { + if (riPtr->interp == interp) { + if (name != NULL) { + if (prevPtr == NULL) { + tsdPtr->interpListPtr = tsdPtr->interpListPtr->nextPtr; + } else { + prevPtr->nextPtr = riPtr->nextPtr; + } + break; + } else { + /* + * The name was NULL, so the caller is asking for the name of + * the current interp. + */ + + return riPtr->name; + } + } + } + + if (name == NULL) { + /* + * The name was NULL, so the caller is asking for the name of the + * current interp, but it doesn't have a name. + */ + + return TEXT(""); + } + + /* + * Get the list of currently registered Tcl interpreters by calling the + * internal implementation of the 'dde services' command. + */ + + Tcl_DStringInit(&dString); + actualName = name; + + if (!(flags & DDE_FLAG_FORCE)) { + r = DdeGetServicesList(interp, TCL_DDE_SERVICE_NAME, NULL); + if (r == TCL_OK) { + srvListPtr = Tcl_GetObjResult(interp); + } + if (r == TCL_OK) { + r = Tcl_ListObjGetElements(interp, srvListPtr, &srvCount, + &srvPtrPtr); + } + if (r != TCL_OK) { + Tcl_WinUtfToTChar(Tcl_GetStringResult(interp), -1, &dString); + OutputDebugString((TCHAR *) Tcl_DStringValue(&dString)); + Tcl_DStringFree(&dString); + return NULL; + } + + /* + * Pick a name to use for the application. Use "name" if it's not + * already in use. Otherwise add a suffix such as " #2", trying larger + * and larger numbers until we eventually find one that is unique. + */ + + offset = lastSuffix = 0; + suffix = 1; + + while (suffix != lastSuffix) { + lastSuffix = suffix; + if (suffix > 1) { + if (suffix == 2) { + Tcl_DStringAppend(&dString, (char *)name, _tcslen(name) * sizeof(TCHAR)); + Tcl_DStringAppend(&dString, (char *)TEXT(" #"), 2 * sizeof(TCHAR)); + offset = Tcl_DStringLength(&dString); + Tcl_DStringSetLength(&dString, offset + sizeof(TCHAR) * TCL_INTEGER_SPACE); + actualName = (TCHAR *) Tcl_DStringValue(&dString); + } + _sntprintf((TCHAR *) (Tcl_DStringValue(&dString) + offset), + TCL_INTEGER_SPACE, TEXT("%d"), suffix); + } + + /* + * See if the name is already in use, if so increment suffix. + */ + + for (n = 0; n < srvCount; ++n) { + Tcl_Obj* namePtr; + Tcl_DString ds; + + Tcl_ListObjIndex(interp, srvPtrPtr[n], 1, &namePtr); + Tcl_WinUtfToTChar(Tcl_GetString(namePtr), -1, &ds); + if (_tcscmp(actualName, (TCHAR *)Tcl_DStringValue(&ds)) == 0) { + suffix++; + Tcl_DStringFree(&ds); + break; + } + Tcl_DStringFree(&ds); + } + } + } + + /* + * We have found a unique name. Now add it to the registry. + */ + + riPtr = ckalloc(sizeof(RegisteredInterp)); + riPtr->interp = interp; + riPtr->name = ckalloc((_tcslen(actualName) + 1) * sizeof(TCHAR)); + riPtr->nextPtr = tsdPtr->interpListPtr; + riPtr->handlerPtr = handlerPtr; + if (riPtr->handlerPtr != NULL) { + Tcl_IncrRefCount(riPtr->handlerPtr); + } + tsdPtr->interpListPtr = riPtr; + _tcscpy(riPtr->name, actualName); + + if (Tcl_IsSafe(interp)) { + Tcl_ExposeCommand(interp, "dde", "dde"); + } + + Tcl_CreateObjCommand(interp, "dde", DdeObjCmd, + riPtr, DeleteProc); + if (Tcl_IsSafe(interp)) { + Tcl_HideCommand(interp, "dde", "dde"); + } + Tcl_DStringFree(&dString); + + /* + * Re-initialize with the new name. + */ + + Initialize(); + + return riPtr->name; +} + +/* + *---------------------------------------------------------------------- + * + * DdeGetRegistrationPtr + * + * Retrieve the registration info for an interpreter. + * + * Results: + * Returns a pointer to the registration structure or NULL + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +static RegisteredInterp * +DdeGetRegistrationPtr( + Tcl_Interp *interp) +{ + RegisteredInterp *riPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; + riPtr = riPtr->nextPtr) { + if (riPtr->interp == interp) { + break; + } + } + return riPtr; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteProc + * + * This function is called when the command "dde" is destroyed. + * + * Results: + * none + * + * Side effects: + * The interpreter given by riPtr is unregistered. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteProc( + ClientData clientData) /* The interp we are deleting passed as + * ClientData. */ +{ + RegisteredInterp *riPtr = (RegisteredInterp *) clientData; + RegisteredInterp *searchPtr, *prevPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + for (searchPtr = tsdPtr->interpListPtr, prevPtr = NULL; + (searchPtr != NULL) && (searchPtr != riPtr); + prevPtr = searchPtr, searchPtr = searchPtr->nextPtr) { + /* + * Empty loop body. + */ + } + + if (searchPtr != NULL) { + if (prevPtr == NULL) { + tsdPtr->interpListPtr = tsdPtr->interpListPtr->nextPtr; + } else { + prevPtr->nextPtr = searchPtr->nextPtr; + } + } + ckfree(riPtr->name); + if (riPtr->handlerPtr) { + Tcl_DecrRefCount(riPtr->handlerPtr); + } + Tcl_EventuallyFree(clientData, TCL_DYNAMIC); +} + +/* + *---------------------------------------------------------------------- + * + * ExecuteRemoteObject -- + * + * Takes the package delivered by DDE and executes it in the server's + * interpreter. + * + * Results: + * A list Tcl_Obj * that describes what happened. The first element is + * the numerical return code (TCL_ERROR, etc.). The second element is the + * result of the script. If the return result was TCL_ERROR, then the + * third element will be the value of the global "errorCode", and the + * fourth will be the value of the global "errorInfo". The return result + * will have a refCount of 0. + * + * Side effects: + * A Tcl script is run, which can cause all kinds of other things to + * happen. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Obj * +ExecuteRemoteObject( + RegisteredInterp *riPtr, /* Info about this server. */ + Tcl_Obj *ddeObjectPtr) /* The object to execute. */ +{ + Tcl_Obj *returnPackagePtr; + int result = TCL_OK; + + if (riPtr->handlerPtr == NULL && Tcl_IsSafe(riPtr->interp)) { + Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj("permission denied: " + "a handler procedure must be defined for use in a safe " + "interp", -1)); + Tcl_SetErrorCode(riPtr->interp, "TCL", "DDE", "SECURITY_CHECK", NULL); + result = TCL_ERROR; + } + + if (riPtr->handlerPtr != NULL) { + /* + * Add the dde request data to the handler proc list. + */ + + Tcl_Obj *cmdPtr = Tcl_DuplicateObj(riPtr->handlerPtr); + + result = Tcl_ListObjAppendElement(riPtr->interp, cmdPtr, + ddeObjectPtr); + if (result == TCL_OK) { + ddeObjectPtr = cmdPtr; + } + } + + if (result == TCL_OK) { + result = Tcl_EvalObjEx(riPtr->interp, ddeObjectPtr, TCL_EVAL_GLOBAL); + } + + returnPackagePtr = Tcl_NewListObj(0, NULL); + + Tcl_ListObjAppendElement(NULL, returnPackagePtr, + Tcl_NewIntObj(result)); + Tcl_ListObjAppendElement(NULL, returnPackagePtr, + Tcl_GetObjResult(riPtr->interp)); + + if (result == TCL_ERROR) { + Tcl_Obj *errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorCode", NULL, + TCL_GLOBAL_ONLY); + if (errorObjPtr) { + Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr); + } + errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorInfo", NULL, + TCL_GLOBAL_ONLY); + if (errorObjPtr) { + Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr); + } + } + + return returnPackagePtr; +} + +/* + *---------------------------------------------------------------------- + * + * DdeServerProc -- + * + * Handles all transactions for this server. Can handle execute, request, + * and connect protocols. Dde will call this routine when a client + * attempts to run a dde command using this server. + * + * Results: + * A DDE Handle with the result of the dde command. + * + * Side effects: + * Depending on which command is executed, arbitrary Tcl scripts can be + * run. + * + *---------------------------------------------------------------------- + */ + +static HDDEDATA CALLBACK +DdeServerProc( + UINT uType, /* The type of DDE transaction we are + * performing. */ + UINT uFmt, /* The format that data is sent or received */ + HCONV hConv, /* The conversation associated with the + * current transaction. */ + HSZ ddeTopic, HSZ ddeItem, /* String handles. Transaction-type + * dependent. */ + HDDEDATA hData, /* DDE data. Transaction-type dependent. */ + DWORD dwData1, DWORD dwData2) + /* Transaction-dependent data. */ +{ + Tcl_DString dString; + int len; + DWORD dlen; + TCHAR *utilString; + Tcl_Obj *ddeObjectPtr; + HDDEDATA ddeReturn = NULL; + RegisteredInterp *riPtr; + Conversation *convPtr, *prevConvPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + switch(uType) { + case XTYP_CONNECT: + /* + * Dde is trying to initialize a conversation with us. Check and make + * sure we have a valid topic. + */ + + len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, CP_WINUNICODE); + Tcl_DStringInit(&dString); + Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); + utilString = (TCHAR *) Tcl_DStringValue(&dString); + DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1, + CP_WINUNICODE); + + for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; + riPtr = riPtr->nextPtr) { + if (_tcsicmp(utilString, riPtr->name) == 0) { + Tcl_DStringFree(&dString); + return (HDDEDATA) TRUE; + } + } + + Tcl_DStringFree(&dString); + return (HDDEDATA) FALSE; + + case XTYP_CONNECT_CONFIRM: + /* + * Dde has decided that we can connect, so it gives us a conversation + * handle. We need to keep track of it so we know which execution + * result to return in an XTYP_REQUEST. + */ + + len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, CP_WINUNICODE); + Tcl_DStringInit(&dString); + Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); + utilString = (TCHAR *) Tcl_DStringValue(&dString); + DdeQueryString(ddeInstance, ddeTopic, utilString, (DWORD) len + 1, + CP_WINUNICODE); + for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; + riPtr = riPtr->nextPtr) { + if (_tcsicmp(riPtr->name, utilString) == 0) { + convPtr = ckalloc(sizeof(Conversation)); + convPtr->nextPtr = tsdPtr->currentConversations; + convPtr->returnPackagePtr = NULL; + convPtr->hConv = hConv; + convPtr->riPtr = riPtr; + tsdPtr->currentConversations = convPtr; + break; + } + } + Tcl_DStringFree(&dString); + return (HDDEDATA) TRUE; + + case XTYP_DISCONNECT: + /* + * The client has disconnected from our server. Forget this + * conversation. + */ + + for (convPtr = tsdPtr->currentConversations, prevConvPtr = NULL; + convPtr != NULL; + prevConvPtr = convPtr, convPtr = convPtr->nextPtr) { + if (hConv == convPtr->hConv) { + if (prevConvPtr == NULL) { + tsdPtr->currentConversations = convPtr->nextPtr; + } else { + prevConvPtr->nextPtr = convPtr->nextPtr; + } + if (convPtr->returnPackagePtr != NULL) { + Tcl_DecrRefCount(convPtr->returnPackagePtr); + } + ckfree(convPtr); + break; + } + } + return (HDDEDATA) TRUE; + + case XTYP_REQUEST: + /* + * This could be either a request for a value of a Tcl variable, or it + * could be the send command requesting the results of the last + * execute. + */ + + if ((uFmt != CF_TEXT) && (uFmt != CF_UNICODETEXT)) { + return (HDDEDATA) FALSE; + } + + ddeReturn = (HDDEDATA) FALSE; + for (convPtr = tsdPtr->currentConversations; (convPtr != NULL) + && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) { + /* + * Empty loop body. + */ + } + + if (convPtr != NULL) { + char *returnString; + + len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE); + Tcl_DStringInit(&dString); + Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); + utilString = (TCHAR *) Tcl_DStringValue(&dString); + DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1, + CP_WINUNICODE); + if (_tcsicmp(utilString, TCL_DDE_EXECUTE_RESULT) == 0) { + if (uFmt == CF_TEXT) { + returnString = + Tcl_GetStringFromObj(convPtr->returnPackagePtr, &len); + } else { + returnString = (char *) + Tcl_GetUnicodeFromObj(convPtr->returnPackagePtr, &len); + len = sizeof(TCHAR) * len + 1; + } + ddeReturn = DdeCreateDataHandle(ddeInstance, (BYTE *)returnString, + (DWORD) len+1, 0, ddeItem, uFmt, 0); + } else { + if (Tcl_IsSafe(convPtr->riPtr->interp)) { + ddeReturn = NULL; + } else { + Tcl_DString ds; + Tcl_Obj *variableObjPtr; + Tcl_WinTCharToUtf(utilString, -1, &ds); + variableObjPtr = Tcl_GetVar2Ex( + convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL, + TCL_GLOBAL_ONLY); + if (variableObjPtr != NULL) { + if (uFmt == CF_TEXT) { + returnString = Tcl_GetStringFromObj( + variableObjPtr, &len); + } else { + returnString = (char *) Tcl_GetUnicodeFromObj( + variableObjPtr, &len); + len = sizeof(TCHAR) * len + 1; + } + ddeReturn = DdeCreateDataHandle(ddeInstance, + (BYTE *)returnString, (DWORD) len+1, 0, ddeItem, + uFmt, 0); + } else { + ddeReturn = NULL; + } + Tcl_DStringFree(&ds); + } + } + Tcl_DStringFree(&dString); + } + return ddeReturn; + +#if !CBF_FAIL_POKES + case XTYP_POKE: + /* + * This is a poke for a Tcl variable, only implemented in + * debug/UNICODE mode. + */ + ddeReturn = DDE_FNOTPROCESSED; + + if ((uFmt != CF_TEXT) && (uFmt != CF_UNICODETEXT)) { + return ddeReturn; + } + + for (convPtr = tsdPtr->currentConversations; (convPtr != NULL) + && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) { + /* + * Empty loop body. + */ + } + + if (convPtr && !Tcl_IsSafe(convPtr->riPtr->interp)) { + Tcl_DString ds; + Tcl_Obj *variableObjPtr; + + len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE); + Tcl_DStringInit(&dString); + Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); + utilString = (TCHAR *) Tcl_DStringValue(&dString); + DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1, + CP_WINUNICODE); + Tcl_WinTCharToUtf(utilString, -1, &ds); + utilString = (TCHAR *) DdeAccessData(hData, &dlen); + if (uFmt == CF_TEXT) { + variableObjPtr = Tcl_NewStringObj((char *)utilString, -1); + } else { + variableObjPtr = Tcl_NewUnicodeObj(utilString, -1); + } + + Tcl_SetVar2Ex(convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL, + variableObjPtr, TCL_GLOBAL_ONLY); + + Tcl_DStringFree(&ds); + Tcl_DStringFree(&dString); + ddeReturn = (HDDEDATA) DDE_FACK; + } + return ddeReturn; + +#endif + case XTYP_EXECUTE: { + /* + * Execute this script. The results will be saved into a list object + * which will be retreived later. See ExecuteRemoteObject. + */ + + Tcl_Obj *returnPackagePtr; + char *string; + + for (convPtr = tsdPtr->currentConversations; (convPtr != NULL) + && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) { + /* + * Empty loop body. + */ + } + + if (convPtr == NULL) { + return (HDDEDATA) DDE_FNOTPROCESSED; + } + + utilString = (TCHAR *) DdeAccessData(hData, &dlen); + string = (char *) utilString; + if (!dlen) { + /* Empty binary array. */ + ddeObjectPtr = Tcl_NewObj(); + } else if ((dlen & 1) || utilString[(dlen>>1)-1]) { + /* Cannot be unicode, so assume utf-8 */ + if (!string[dlen-1]) { + dlen--; + } + ddeObjectPtr = Tcl_NewStringObj(string, dlen); + } else { + /* unicode */ + dlen >>= 1; + ddeObjectPtr = Tcl_NewUnicodeObj((Tcl_UniChar *)utilString, dlen - 1); + } + Tcl_IncrRefCount(ddeObjectPtr); + DdeUnaccessData(hData); + if (convPtr->returnPackagePtr != NULL) { + Tcl_DecrRefCount(convPtr->returnPackagePtr); + } + convPtr->returnPackagePtr = NULL; + returnPackagePtr = ExecuteRemoteObject(convPtr->riPtr, ddeObjectPtr); + Tcl_IncrRefCount(returnPackagePtr); + for (convPtr = tsdPtr->currentConversations; (convPtr != NULL) + && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) { + /* + * Empty loop body. + */ + } + if (convPtr != NULL) { + convPtr->returnPackagePtr = returnPackagePtr; + } else { + Tcl_DecrRefCount(returnPackagePtr); + } + Tcl_DecrRefCount(ddeObjectPtr); + if (returnPackagePtr == NULL) { + return (HDDEDATA) DDE_FNOTPROCESSED; + } else { + return (HDDEDATA) DDE_FACK; + } + } + + case XTYP_WILDCONNECT: { + /* + * Dde wants a list of services and topics that we support. + */ + + HSZPAIR *returnPtr; + int i; + int numItems; + + for (i = 0, riPtr = tsdPtr->interpListPtr; riPtr != NULL; + i++, riPtr = riPtr->nextPtr) { + /* + * Empty loop body. + */ + } + + numItems = i; + ddeReturn = DdeCreateDataHandle(ddeInstance, NULL, + (numItems + 1) * sizeof(HSZPAIR), 0, 0, 0, 0); + returnPtr = (HSZPAIR *) DdeAccessData(ddeReturn, &dlen); + len = dlen; + for (i = 0, riPtr = tsdPtr->interpListPtr; i < numItems; + i++, riPtr = riPtr->nextPtr) { + returnPtr[i].hszSvc = DdeCreateStringHandle(ddeInstance, + TCL_DDE_SERVICE_NAME, CP_WINUNICODE); + returnPtr[i].hszTopic = DdeCreateStringHandle(ddeInstance, + riPtr->name, CP_WINUNICODE); + } + returnPtr[i].hszSvc = NULL; + returnPtr[i].hszTopic = NULL; + DdeUnaccessData(ddeReturn); + return ddeReturn; + } + + default: + return NULL; + } +} + +/* + *---------------------------------------------------------------------- + * + * DdeExitProc -- + * + * Gets rid of our DDE server when we go away. + * + * Results: + * None. + * + * Side effects: + * The DDE server is deleted. + * + *---------------------------------------------------------------------- + */ + +static void +DdeExitProc( + ClientData clientData) /* Not used in this handler. */ +{ + DdeNameService(ddeInstance, NULL, 0, DNS_UNREGISTER); + DdeUninitialize(ddeInstance); + ddeInstance = 0; +} + +/* + *---------------------------------------------------------------------- + * + * MakeDdeConnection -- + * + * This function is a utility used to connect to a DDE server when given + * a server name and a topic name. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Passes back a conversation through ddeConvPtr + * + *---------------------------------------------------------------------- + */ + +static int +MakeDdeConnection( + Tcl_Interp *interp, /* Used to report errors. */ + const TCHAR *name, /* The connection to use. */ + HCONV *ddeConvPtr) +{ + HSZ ddeTopic, ddeService; + HCONV ddeConv; + + ddeService = DdeCreateStringHandle(ddeInstance, TCL_DDE_SERVICE_NAME, CP_WINUNICODE); + ddeTopic = DdeCreateStringHandle(ddeInstance, name, CP_WINUNICODE); + + ddeConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); + DdeFreeStringHandle(ddeInstance, ddeService); + DdeFreeStringHandle(ddeInstance, ddeTopic); + + if (ddeConv == (HCONV) NULL) { + if (interp != NULL) { + Tcl_DString dString; + + Tcl_WinTCharToUtf(name, -1, &dString); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "no registered server named \"%s\"", Tcl_DStringValue(&dString))); + Tcl_DStringFree(&dString); + Tcl_SetErrorCode(interp, "TCL", "DDE", "NO_SERVER", NULL); + } + return TCL_ERROR; + } + + *ddeConvPtr = ddeConv; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * DdeGetServicesList -- + * + * This function obtains the list of DDE services. + * + * The functions between here and this function are all involved with + * handling the DDE callbacks for this. They are: DdeCreateClient, + * DdeClientWindowProc, DdeServicesOnAck, and DdeEnumWindowsCallback + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Sets the services list into the interp result. + * + *---------------------------------------------------------------------- + */ + +static int +DdeCreateClient( + struct DdeEnumServices *es) +{ + WNDCLASSEX wc; + static const TCHAR *szDdeClientClassName = TEXT("TclEval client class"); + static const TCHAR *szDdeClientWindowName = TEXT("TclEval client window"); + + memset(&wc, 0, sizeof(wc)); + wc.cbSize = sizeof(wc); + wc.lpfnWndProc = DdeClientWindowProc; + wc.lpszClassName = szDdeClientClassName; + wc.cbWndExtra = sizeof(struct DdeEnumServices *); + + /* + * Register and create the callback window. + */ + + RegisterClassEx(&wc); + es->hwnd = CreateWindowEx(0, szDdeClientClassName, szDdeClientWindowName, + WS_POPUP, 0, 0, 0, 0, NULL, NULL, NULL, (LPVOID)es); + return TCL_OK; +} + +static LRESULT CALLBACK +DdeClientWindowProc( + HWND hwnd, /* What window is the message for */ + UINT uMsg, /* The type of message received */ + WPARAM wParam, + LPARAM lParam) /* (Potentially) our local handle */ +{ + switch (uMsg) { + case WM_CREATE: { + LPCREATESTRUCT lpcs = (LPCREATESTRUCT) lParam; + struct DdeEnumServices *es = + (struct DdeEnumServices *) lpcs->lpCreateParams; + +#ifdef _WIN64 + SetWindowLongPtr(hwnd, GWLP_USERDATA, (LONG_PTR) es); +#else + SetWindowLong(hwnd, GWL_USERDATA, (LONG) es); +#endif + return (LRESULT) 0L; + } + case WM_DDE_ACK: + return DdeServicesOnAck(hwnd, wParam, lParam); + default: + return DefWindowProc(hwnd, uMsg, wParam, lParam); + } +} + +static LRESULT +DdeServicesOnAck( + HWND hwnd, + WPARAM wParam, + LPARAM lParam) +{ + HWND hwndRemote = (HWND)wParam; + ATOM service = (ATOM)LOWORD(lParam); + ATOM topic = (ATOM)HIWORD(lParam); + struct DdeEnumServices *es; + TCHAR sz[255]; + Tcl_DString dString; + +#ifdef _WIN64 + es = (struct DdeEnumServices *) GetWindowLongPtr(hwnd, GWLP_USERDATA); +#else + es = (struct DdeEnumServices *) GetWindowLong(hwnd, GWL_USERDATA); +#endif + + if ((es->service == (ATOM)0 || es->service == service) + && (es->topic == (ATOM)0 || es->topic == topic)) { + Tcl_Obj *matchPtr = Tcl_NewListObj(0, NULL); + Tcl_Obj *resultPtr = Tcl_GetObjResult(es->interp); + + GlobalGetAtomName(service, sz, 255); + Tcl_WinTCharToUtf(sz, -1, &dString); + Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), -1)); + Tcl_DStringFree(&dString); + GlobalGetAtomName(topic, sz, 255); + Tcl_WinTCharToUtf(sz, -1, &dString); + Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), -1)); + Tcl_DStringFree(&dString); + + /* + * Adding the hwnd as a third list element provides a unique + * identifier in the case of multiple servers with the name + * application and topic names. + */ + /* + * Needs a TIP though: + * Tcl_ListObjAppendElement(NULL, matchPtr, + * Tcl_NewLongObj((long)hwndRemote)); + */ + + if (Tcl_IsShared(resultPtr)) { + resultPtr = Tcl_DuplicateObj(resultPtr); + } + if (Tcl_ListObjAppendElement(es->interp, resultPtr, + matchPtr) == TCL_OK) { + Tcl_SetObjResult(es->interp, resultPtr); + } + } + + /* + * Tell the server we are no longer interested. + */ + + PostMessage(hwndRemote, WM_DDE_TERMINATE, (WPARAM)hwnd, 0L); + return 0L; +} + +static BOOL CALLBACK +DdeEnumWindowsCallback( + HWND hwndTarget, + LPARAM lParam) +{ + DWORD_PTR dwResult = 0; + struct DdeEnumServices *es = (struct DdeEnumServices *) lParam; + + SendMessageTimeout(hwndTarget, WM_DDE_INITIATE, (WPARAM)es->hwnd, + MAKELONG(es->service, es->topic), SMTO_ABORTIFHUNG, 1000, + &dwResult); + return TRUE; +} + +static int +DdeGetServicesList( + Tcl_Interp *interp, + const TCHAR *serviceName, + const TCHAR *topicName) +{ + struct DdeEnumServices es; + + es.interp = interp; + es.result = TCL_OK; + es.service = (serviceName == NULL) + ? (ATOM)0 : GlobalAddAtom(serviceName); + es.topic = (topicName == NULL) ? (ATOM)0 : GlobalAddAtom(topicName); + + Tcl_ResetResult(interp); /* our list is to be appended to result. */ + DdeCreateClient(&es); + EnumWindows(DdeEnumWindowsCallback, (LPARAM)&es); + + if (IsWindow(es.hwnd)) { + DestroyWindow(es.hwnd); + } + if (es.service != (ATOM)0) { + GlobalDeleteAtom(es.service); + } + if (es.topic != (ATOM)0) { + GlobalDeleteAtom(es.topic); + } + return es.result; +} + +/* + *---------------------------------------------------------------------- + * + * SetDdeError -- + * + * Sets the interp result to a cogent error message describing the last + * DDE error. + * + * Results: + * None. + * + * Side effects: + * The interp's result object is changed. + * + *---------------------------------------------------------------------- + */ + +static void +SetDdeError( + Tcl_Interp *interp) /* The interp to put the message in. */ +{ + const char *errorMessage, *errorCode; + + switch (DdeGetLastError(ddeInstance)) { + case DMLERR_DATAACKTIMEOUT: + case DMLERR_EXECACKTIMEOUT: + case DMLERR_POKEACKTIMEOUT: + errorMessage = "remote interpreter did not respond"; + errorCode = "TIMEOUT"; + break; + case DMLERR_BUSY: + errorMessage = "remote server is busy"; + errorCode = "BUSY"; + break; + case DMLERR_NOTPROCESSED: + errorMessage = "remote server cannot handle this command"; + errorCode = "NOCANDO"; + break; + default: + errorMessage = "dde command failed"; + errorCode = "FAILED"; + } + + Tcl_SetObjResult(interp, Tcl_NewStringObj(errorMessage, -1)); + Tcl_SetErrorCode(interp, "TCL", "DDE", errorCode, NULL); +} + +/* + *---------------------------------------------------------------------- + * + * DdeObjCmd -- + * + * This function is invoked to process the "dde" Tcl command. See the + * user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +DdeObjCmd( + ClientData clientData, /* Used only for deletion */ + Tcl_Interp *interp, /* The interp we are sending from */ + int objc, /* Number of arguments */ + Tcl_Obj *const *objv) /* The arguments */ +{ + static const char *const ddeCommands[] = { + "servername", "execute", "poke", "request", "services", "eval", + (char *) NULL}; + enum DdeSubcommands { + DDE_SERVERNAME, DDE_EXECUTE, DDE_POKE, DDE_REQUEST, DDE_SERVICES, + DDE_EVAL + }; + static const char *const ddeSrvOptions[] = { + "-force", "-handler", "--", NULL + }; + enum DdeSrvOptions { + DDE_SERVERNAME_EXACT, DDE_SERVERNAME_HANDLER, DDE_SERVERNAME_LAST, + }; + static const char *const ddeExecOptions[] = { + "-async", "-binary", NULL + }; + enum DdeExecOptions { + DDE_EXEC_ASYNC, DDE_EXEC_BINARY + }; + static const char *const ddeEvalOptions[] = { + "-async", NULL + }; + static const char *const ddeReqOptions[] = { + "-binary", NULL + }; + + int index, i, length, argIndex; + int flags = 0, result = TCL_OK, firstArg = 0; + HSZ ddeService = NULL, ddeTopic = NULL, ddeItem = NULL, ddeCookie = NULL; + HDDEDATA ddeData = NULL, ddeItemData = NULL, ddeReturn; + HCONV hConv = NULL; + const TCHAR *serviceName = NULL, *topicName = NULL; + const char *string; + DWORD ddeResult; + Tcl_Obj *objPtr, *handlerPtr = NULL; + + /* + * Initialize DDE server/client + */ + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?"); + return TCL_ERROR; + } + + if (Tcl_GetIndexFromObj(interp, objv[1], ddeCommands, "command", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + switch ((enum DdeSubcommands) index) { + case DDE_SERVERNAME: + for (i = 2; i < objc; i++) { + if (Tcl_GetIndexFromObj(interp, objv[i], ddeSrvOptions, + "option", 0, &argIndex) != TCL_OK) { + /* + * If it is the last argument, it might be a server name + * instead of a bad argument. + */ + + if (i != objc-1) { + return TCL_ERROR; + } + Tcl_ResetResult(interp); + break; + } + if (argIndex == DDE_SERVERNAME_EXACT) { + flags |= DDE_FLAG_FORCE; + } else if (argIndex == DDE_SERVERNAME_HANDLER) { + if ((objc - i) == 1) { /* return current handler */ + RegisteredInterp *riPtr = DdeGetRegistrationPtr(interp); + + if (riPtr && riPtr->handlerPtr) { + Tcl_SetObjResult(interp, riPtr->handlerPtr); + } else { + Tcl_ResetResult(interp); + } + return TCL_OK; + } + handlerPtr = objv[++i]; + } else if (argIndex == DDE_SERVERNAME_LAST) { + i++; + break; + } + } + + if ((objc - i) > 1) { + Tcl_ResetResult(interp); + Tcl_WrongNumArgs(interp, 2, objv, + "?-force? ?-handler proc? ?--? ?serverName?"); + return TCL_ERROR; + } + + firstArg = (objc == i) ? 1 : i; + break; + case DDE_EXECUTE: + if (objc == 5) { + firstArg = 2; + break; + } else if (objc >= 6 && objc <= 7) { + firstArg = objc - 3; + for (i = 2; i < firstArg; i++) { + if (Tcl_GetIndexFromObj(interp, objv[i], ddeExecOptions, + "option", 0, &argIndex) != TCL_OK) { + goto wrongDdeExecuteArgs; + } + if (argIndex == DDE_EXEC_ASYNC) { + flags |= DDE_FLAG_ASYNC; + } else { + flags |= DDE_FLAG_BINARY; + } + } + break; + } + /* otherwise... */ + wrongDdeExecuteArgs: + Tcl_WrongNumArgs(interp, 2, objv, + "?-async? ?-binary? serviceName topicName value"); + return TCL_ERROR; + case DDE_POKE: + if (objc == 6) { + firstArg = 2; + break; + } else if ((objc == 7) && (Tcl_GetIndexFromObj(NULL, objv[2], + ddeReqOptions, "option", 0, &argIndex) == TCL_OK)) { + flags |= DDE_FLAG_BINARY; + firstArg = 3; + break; + } + + /* + * Otherwise... + */ + + Tcl_WrongNumArgs(interp, 2, objv, + "?-binary? serviceName topicName item value"); + return TCL_ERROR; + case DDE_REQUEST: + if (objc == 5) { + firstArg = 2; + break; + } else if ((objc == 6) && (Tcl_GetIndexFromObj(NULL, objv[2], + ddeReqOptions, "option", 0, &argIndex) == TCL_OK)) { + flags |= DDE_FLAG_BINARY; + firstArg = 3; + break; + } + + /* + * Otherwise ... + */ + + Tcl_WrongNumArgs(interp, 2, objv, + "?-binary? serviceName topicName value"); + return TCL_ERROR; + case DDE_SERVICES: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "serviceName topicName"); + return TCL_ERROR; + } + firstArg = 2; + break; + case DDE_EVAL: + if (objc < 4) { + wrongDdeEvalArgs: + Tcl_WrongNumArgs(interp, 2, objv, "?-async? serviceName args"); + return TCL_ERROR; + } else { + firstArg = 2; + if (Tcl_GetIndexFromObj(NULL, objv[2], ddeEvalOptions, "option", + 0, &argIndex) == TCL_OK) { + if (objc < 5) { + goto wrongDdeEvalArgs; + } + flags |= DDE_FLAG_ASYNC; + firstArg++; + } + break; + } + } + + Initialize(); + + if (firstArg != 1) { +#ifdef UNICODE + serviceName = Tcl_GetUnicodeFromObj(objv[firstArg], &length); +#else + serviceName = Tcl_GetStringFromObj(objv[firstArg], &length); +#endif + } else { + length = 0; + } + + if (length == 0) { + serviceName = NULL; + } else if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) { + ddeService = DdeCreateStringHandle(ddeInstance, (void *) serviceName, + CP_WINUNICODE); + } + + if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) { +#ifdef UNICODE + topicName = (TCHAR *) Tcl_GetUnicodeFromObj(objv[firstArg + 1], &length); +#else + topicName = Tcl_GetStringFromObj(objv[firstArg + 1], &length); +#endif + if (length == 0) { + topicName = NULL; + } else { + ddeTopic = DdeCreateStringHandle(ddeInstance, (void *) topicName, + CP_WINUNICODE); + } + } + + switch ((enum DdeSubcommands) index) { + case DDE_SERVERNAME: + serviceName = DdeSetServerName(interp, serviceName, flags, + handlerPtr); + if (serviceName != NULL) { +#ifdef UNICODE + Tcl_SetObjResult(interp, Tcl_NewUnicodeObj((Tcl_UniChar *) serviceName, -1)); +#else + Tcl_SetObjResult(interp, Tcl_NewStringObj(serviceName, -1)); +#endif + } else { + Tcl_ResetResult(interp); + } + break; + + case DDE_EXECUTE: { + int dataLength; + const Tcl_UniChar *dataString; + + if (flags & DDE_FLAG_BINARY) { + dataString = (const Tcl_UniChar *) + Tcl_GetByteArrayFromObj(objv[firstArg + 2], &dataLength); + } else { + dataString = + Tcl_GetUnicodeFromObj(objv[firstArg + 2], &dataLength); + dataLength = (dataLength + 1) * sizeof(Tcl_UniChar); + } + + if (dataLength <= 0) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("cannot execute null data", -1)); + Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL); + result = TCL_ERROR; + break; + } + hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); + DdeFreeStringHandle(ddeInstance, ddeService); + DdeFreeStringHandle(ddeInstance, ddeTopic); + + if (hConv == NULL) { + SetDdeError(interp); + result = TCL_ERROR; + break; + } + + ddeData = DdeCreateDataHandle(ddeInstance, (BYTE *) dataString, + (DWORD) dataLength, 0, 0, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, 0); + if (ddeData != NULL) { + if (flags & DDE_FLAG_ASYNC) { + DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, hConv, 0, + (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); + DdeAbandonTransaction(ddeInstance, hConv, ddeResult); + } else { + ddeReturn = DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, + hConv, 0, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_EXECUTE, 30000, NULL); + if (ddeReturn == 0) { + SetDdeError(interp); + result = TCL_ERROR; + } + } + DdeFreeDataHandle(ddeData); + } else { + SetDdeError(interp); + result = TCL_ERROR; + } + break; + } + case DDE_REQUEST: { +#ifdef UNICODE + const TCHAR *itemString = (TCHAR *) Tcl_GetUnicodeFromObj(objv[firstArg + 2], + &length); +#else + const TCHAR *itemString = Tcl_GetStringFromObj(objv[firstArg + 2], + &length); +#endif + + if (length == 0) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("cannot request value of null data", -1)); + Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL); + result = TCL_ERROR; + goto cleanup; + } + hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); + DdeFreeStringHandle(ddeInstance, ddeService); + DdeFreeStringHandle(ddeInstance, ddeTopic); + + if (hConv == NULL) { + SetDdeError(interp); + result = TCL_ERROR; + } else { + Tcl_Obj *returnObjPtr; + ddeItem = DdeCreateStringHandle(ddeInstance, (void *) itemString, + CP_WINUNICODE); + if (ddeItem != NULL) { + ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem, + (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_REQUEST, 5000, NULL); + if (ddeData == NULL) { + SetDdeError(interp); + result = TCL_ERROR; + } else { + DWORD tmp; + const Tcl_UniChar *dataString = (const Tcl_UniChar *) DdeAccessData(ddeData, &tmp); + + if (flags & DDE_FLAG_BINARY) { + returnObjPtr = + Tcl_NewByteArrayObj((BYTE *) dataString, (int) tmp); + } else { + tmp >>= 1; + if (tmp && !dataString[(tmp-1)]) { + --tmp; + } + returnObjPtr = Tcl_NewUnicodeObj(dataString, + (int) tmp); + } + DdeUnaccessData(ddeData); + DdeFreeDataHandle(ddeData); + Tcl_SetObjResult(interp, returnObjPtr); + } + } else { + SetDdeError(interp); + result = TCL_ERROR; + } + } + + break; + } + case DDE_POKE: { +#ifdef UNICODE + const TCHAR *itemString = (TCHAR *) Tcl_GetUnicodeFromObj(objv[firstArg + 2], + &length); +#else + const TCHAR *itemString = Tcl_GetStringFromObj(objv[firstArg + 2], + &length); +#endif + BYTE *dataString; + + if (length == 0) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("cannot have a null item", -1)); + Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL); + result = TCL_ERROR; + goto cleanup; + } + if (flags & DDE_FLAG_BINARY) { + dataString = (BYTE *) + Tcl_GetByteArrayFromObj(objv[firstArg + 3], &length); + } else { + dataString = (BYTE *) + Tcl_GetUnicodeFromObj(objv[firstArg + 3], &length); + length = 2 * length + 1; + } + + hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL); + DdeFreeStringHandle(ddeInstance, ddeService); + DdeFreeStringHandle(ddeInstance, ddeTopic); + + if (hConv == NULL) { + SetDdeError(interp); + result = TCL_ERROR; + } else { + ddeItem = DdeCreateStringHandle(ddeInstance, (void *) itemString, + CP_WINUNICODE); + if (ddeItem != NULL) { + ddeData = DdeClientTransaction(dataString, (DWORD) length, + hConv, ddeItem, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_POKE, 5000, NULL); + if (ddeData == NULL) { + SetDdeError(interp); + result = TCL_ERROR; + } + } else { + SetDdeError(interp); + result = TCL_ERROR; + } + } + break; + } + + case DDE_SERVICES: + result = DdeGetServicesList(interp, serviceName, topicName); + break; + + case DDE_EVAL: { + RegisteredInterp *riPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if (serviceName == NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("invalid service name \"\"", -1)); + Tcl_SetErrorCode(interp, "TCL", "DDE", "NO_SERVER", NULL); + result = TCL_ERROR; + goto cleanup; + } + + objc -= firstArg + 1; + objv += firstArg + 1; + + /* + * See if the target interpreter is local. If so, execute the command + * directly without going through the DDE server. Don't exchange + * objects between interps. The target interp could compile an object, + * producing a bytecode structure that refers to other objects owned + * by the target interp. If the target interp is then deleted, the + * bytecode structure would be referring to deallocated objects. + */ + + for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; + riPtr = riPtr->nextPtr) { + if (_tcsicmp(serviceName, riPtr->name) == 0) { + break; + } + } + + if (riPtr != NULL) { + Tcl_Interp *sendInterp; + + /* + * This command is to a local interp. No need to go through the + * server. + */ + + Tcl_Preserve(riPtr); + sendInterp = riPtr->interp; + Tcl_Preserve(sendInterp); + + /* + * Don't exchange objects between interps. The target interp would + * compile an object, producing a bytecode structure that refers + * to other objects owned by the target interp. If the target + * interp is then deleted, the bytecode structure would be + * referring to deallocated objects. + */ + + if (Tcl_IsSafe(riPtr->interp) && riPtr->handlerPtr == NULL) { + Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj( + "permission denied: a handler procedure must be" + " defined for use in a safe interp", -1)); + Tcl_SetErrorCode(interp, "TCL", "DDE", "SECURITY_CHECK", + NULL); + result = TCL_ERROR; + } + + if (result == TCL_OK) { + if (objc == 1) + objPtr = objv[0]; + else { + objPtr = Tcl_ConcatObj(objc, objv); + } + if (riPtr->handlerPtr != NULL) { + /* add the dde request data to the handler proc list */ + /* + *result = Tcl_ListObjReplace(sendInterp, objPtr, 0, 0, 1, + * &(riPtr->handlerPtr)); + */ + Tcl_Obj *cmdPtr = Tcl_DuplicateObj(riPtr->handlerPtr); + result = Tcl_ListObjAppendElement(sendInterp, cmdPtr, + objPtr); + if (result == TCL_OK) { + objPtr = cmdPtr; + } + } + } + if (result == TCL_OK) { + Tcl_IncrRefCount(objPtr); + result = Tcl_EvalObjEx(sendInterp, objPtr, TCL_EVAL_GLOBAL); + Tcl_DecrRefCount(objPtr); + } + if (interp != sendInterp) { + if (result == TCL_ERROR) { + /* + * An error occurred, so transfer error information from + * the destination interpreter back to our interpreter. + */ + + Tcl_ResetResult(interp); + objPtr = Tcl_GetVar2Ex(sendInterp, "errorInfo", NULL, + TCL_GLOBAL_ONLY); + if (objPtr) { + Tcl_AppendObjToErrorInfo(interp, objPtr); + } + + objPtr = Tcl_GetVar2Ex(sendInterp, "errorCode", NULL, + TCL_GLOBAL_ONLY); + if (objPtr) { + Tcl_SetObjErrorCode(interp, objPtr); + } + } + Tcl_SetObjResult(interp, Tcl_GetObjResult(sendInterp)); + } + Tcl_Release(riPtr); + Tcl_Release(sendInterp); + } else { + /* + * This is a non-local request. Send the script to the server and + * poll it for a result. + */ + + if (MakeDdeConnection(interp, serviceName, &hConv) != TCL_OK) { + invalidServerResponse: + Tcl_SetObjResult(interp, + Tcl_NewStringObj("invalid data returned from server", -1)); + Tcl_SetErrorCode(interp, "TCL", "DDE", "BAD_RESPONSE", NULL); + result = TCL_ERROR; + goto cleanup; + } + + objPtr = Tcl_ConcatObj(objc, objv); + string = (const char *) Tcl_GetUnicodeFromObj(objPtr, &length); + ddeItemData = DdeCreateDataHandle(ddeInstance, + (BYTE *) string, (DWORD) 2*length+2, 0, 0, CF_UNICODETEXT, 0); + + if (flags & DDE_FLAG_ASYNC) { + ddeData = DdeClientTransaction((LPBYTE) ddeItemData, + 0xFFFFFFFF, hConv, 0, + CF_UNICODETEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult); + DdeAbandonTransaction(ddeInstance, hConv, ddeResult); + } else { + ddeData = DdeClientTransaction((LPBYTE) ddeItemData, + 0xFFFFFFFF, hConv, 0, + CF_UNICODETEXT, XTYP_EXECUTE, 30000, NULL); + if (ddeData != 0) { + ddeCookie = DdeCreateStringHandle(ddeInstance, + TCL_DDE_EXECUTE_RESULT, CP_WINUNICODE); + ddeData = DdeClientTransaction(NULL, 0, hConv, ddeCookie, + CF_UNICODETEXT, XTYP_REQUEST, 30000, NULL); + } + } + + Tcl_DecrRefCount(objPtr); + + if (ddeData == 0) { + SetDdeError(interp); + result = TCL_ERROR; + goto cleanup; + } + + if (!(flags & DDE_FLAG_ASYNC)) { + Tcl_Obj *resultPtr; + Tcl_UniChar *ddeDataString; + + /* + * The return handle has a two or four element list in it. The + * first element is the return code (TCL_OK, TCL_ERROR, etc.). + * The second is the result of the script. If the return code + * is TCL_ERROR, then the third element is the value of the + * variable "errorCode", and the fourth is the value of the + * variable "errorInfo". + */ + + resultPtr = Tcl_NewObj(); + length = DdeGetData(ddeData, NULL, 0, 0); + ddeDataString = ckalloc(length); + DdeGetData(ddeData, (BYTE *) ddeDataString, (DWORD) length, 0); + length = (length >> 1) - 1; + resultPtr = Tcl_NewUnicodeObj(ddeDataString, length); + ckfree(ddeDataString); + + if (Tcl_ListObjIndex(NULL, resultPtr, 0, &objPtr) != TCL_OK) { + Tcl_DecrRefCount(resultPtr); + goto invalidServerResponse; + } + if (Tcl_GetIntFromObj(NULL, objPtr, &result) != TCL_OK) { + Tcl_DecrRefCount(resultPtr); + goto invalidServerResponse; + } + if (result == TCL_ERROR) { + Tcl_ResetResult(interp); + + if (Tcl_ListObjIndex(NULL, resultPtr, 3, + &objPtr) != TCL_OK) { + Tcl_DecrRefCount(resultPtr); + goto invalidServerResponse; + } + Tcl_AppendObjToErrorInfo(interp, objPtr); + + Tcl_ListObjIndex(NULL, resultPtr, 2, &objPtr); + Tcl_SetObjErrorCode(interp, objPtr); + } + if (Tcl_ListObjIndex(NULL, resultPtr, 1, &objPtr) != TCL_OK) { + Tcl_DecrRefCount(resultPtr); + goto invalidServerResponse; + } + Tcl_SetObjResult(interp, objPtr); + Tcl_DecrRefCount(resultPtr); + } + } + } + } + + cleanup: + if (ddeCookie != NULL) { + DdeFreeStringHandle(ddeInstance, ddeCookie); + } + if (ddeItem != NULL) { + DdeFreeStringHandle(ddeInstance, ddeItem); + } + if (ddeItemData != NULL) { + DdeFreeDataHandle(ddeItemData); + } + if (ddeData != NULL) { + DdeFreeDataHandle(ddeData); + } + if (hConv != NULL) { + DdeDisconnect(hConv); + } + return result; +} + +/* + * Local variables: + * mode: c + * indent-tabs-mode: t + * tab-width: 8 + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/win/tclWinError.c b/win/tclWinError.c new file mode 100644 index 0000000..30079b9 --- /dev/null +++ b/win/tclWinError.c @@ -0,0 +1,428 @@ +/* + * tclWinError.c -- + * + * This file contains code for converting from Win32 errors to errno + * errors. + * + * Copyright (c) 1995-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. + */ + +#include "tclInt.h" +/* + * The following table contains the mapping from Win32 errors to errno errors. + */ + +static const unsigned char errorTable[] = { + 0, + EINVAL, /* ERROR_INVALID_FUNCTION 1 */ + ENOENT, /* ERROR_FILE_NOT_FOUND 2 */ + ENOENT, /* ERROR_PATH_NOT_FOUND 3 */ + EMFILE, /* ERROR_TOO_MANY_OPEN_FILES 4 */ + EACCES, /* ERROR_ACCESS_DENIED 5 */ + EBADF, /* ERROR_INVALID_HANDLE 6 */ + ENOMEM, /* ERROR_ARENA_TRASHED 7 */ + ENOMEM, /* ERROR_NOT_ENOUGH_MEMORY 8 */ + ENOMEM, /* ERROR_INVALID_BLOCK 9 */ + E2BIG, /* ERROR_BAD_ENVIRONMENT 10 */ + ENOEXEC, /* ERROR_BAD_FORMAT 11 */ + EACCES, /* ERROR_INVALID_ACCESS 12 */ + EINVAL, /* ERROR_INVALID_DATA 13 */ + EFAULT, /* ERROR_OUT_OF_MEMORY 14 */ + ENOENT, /* ERROR_INVALID_DRIVE 15 */ + EACCES, /* ERROR_CURRENT_DIRECTORY 16 */ + EXDEV, /* ERROR_NOT_SAME_DEVICE 17 */ + ENOENT, /* ERROR_NO_MORE_FILES 18 */ + EROFS, /* ERROR_WRITE_PROTECT 19 */ + ENXIO, /* ERROR_BAD_UNIT 20 */ + EBUSY, /* ERROR_NOT_READY 21 */ + EIO, /* ERROR_BAD_COMMAND 22 */ + EIO, /* ERROR_CRC 23 */ + EIO, /* ERROR_BAD_LENGTH 24 */ + EIO, /* ERROR_SEEK 25 */ + EIO, /* ERROR_NOT_DOS_DISK 26 */ + ENXIO, /* ERROR_SECTOR_NOT_FOUND 27 */ + EBUSY, /* ERROR_OUT_OF_PAPER 28 */ + EIO, /* ERROR_WRITE_FAULT 29 */ + EIO, /* ERROR_READ_FAULT 30 */ + EIO, /* ERROR_GEN_FAILURE 31 */ + EACCES, /* ERROR_SHARING_VIOLATION 32 */ + EACCES, /* ERROR_LOCK_VIOLATION 33 */ + ENXIO, /* ERROR_WRONG_DISK 34 */ + ENFILE, /* ERROR_FCB_UNAVAILABLE 35 */ + ENFILE, /* ERROR_SHARING_BUFFER_EXCEEDED 36 */ + EINVAL, /* 37 */ + EINVAL, /* 38 */ + ENOSPC, /* ERROR_HANDLE_DISK_FULL 39 */ + EINVAL, /* 40 */ + EINVAL, /* 41 */ + EINVAL, /* 42 */ + EINVAL, /* 43 */ + EINVAL, /* 44 */ + EINVAL, /* 45 */ + EINVAL, /* 46 */ + EINVAL, /* 47 */ + EINVAL, /* 48 */ + EINVAL, /* 49 */ + ENODEV, /* ERROR_NOT_SUPPORTED 50 */ + EBUSY, /* ERROR_REM_NOT_LIST 51 */ + EEXIST, /* ERROR_DUP_NAME 52 */ + ENOENT, /* ERROR_BAD_NETPATH 53 */ + EBUSY, /* ERROR_NETWORK_BUSY 54 */ + ENODEV, /* ERROR_DEV_NOT_EXIST 55 */ + EAGAIN, /* ERROR_TOO_MANY_CMDS 56 */ + EIO, /* ERROR_ADAP_HDW_ERR 57 */ + EIO, /* ERROR_BAD_NET_RESP 58 */ + EIO, /* ERROR_UNEXP_NET_ERR 59 */ + EINVAL, /* ERROR_BAD_REM_ADAP 60 */ + EFBIG, /* ERROR_PRINTQ_FULL 61 */ + ENOSPC, /* ERROR_NO_SPOOL_SPACE 62 */ + ENOENT, /* ERROR_PRINT_CANCELLED 63 */ + ENOENT, /* ERROR_NETNAME_DELETED 64 */ + EACCES, /* ERROR_NETWORK_ACCESS_DENIED 65 */ + ENODEV, /* ERROR_BAD_DEV_TYPE 66 */ + ENOENT, /* ERROR_BAD_NET_NAME 67 */ + ENFILE, /* ERROR_TOO_MANY_NAMES 68 */ + EIO, /* ERROR_TOO_MANY_SESS 69 */ + EAGAIN, /* ERROR_SHARING_PAUSED 70 */ + EINVAL, /* ERROR_REQ_NOT_ACCEP 71 */ + EAGAIN, /* ERROR_REDIR_PAUSED 72 */ + EINVAL, /* 73 */ + EINVAL, /* 74 */ + EINVAL, /* 75 */ + EINVAL, /* 76 */ + EINVAL, /* 77 */ + EINVAL, /* 78 */ + EINVAL, /* 79 */ + EEXIST, /* ERROR_FILE_EXISTS 80 */ + EINVAL, /* 81 */ + ENOSPC, /* ERROR_CANNOT_MAKE 82 */ + EIO, /* ERROR_FAIL_I24 83 */ + ENFILE, /* ERROR_OUT_OF_STRUCTURES 84 */ + EEXIST, /* ERROR_ALREADY_ASSIGNED 85 */ + EPERM, /* ERROR_INVALID_PASSWORD 86 */ + EINVAL, /* ERROR_INVALID_PARAMETER 87 */ + EIO, /* ERROR_NET_WRITE_FAULT 88 */ + EAGAIN, /* ERROR_NO_PROC_SLOTS 89 */ + EINVAL, /* 90 */ + EINVAL, /* 91 */ + EINVAL, /* 92 */ + EINVAL, /* 93 */ + EINVAL, /* 94 */ + EINVAL, /* 95 */ + EINVAL, /* 96 */ + EINVAL, /* 97 */ + EINVAL, /* 98 */ + EINVAL, /* 99 */ + EINVAL, /* 100 */ + EINVAL, /* 101 */ + EINVAL, /* 102 */ + EINVAL, /* 103 */ + EINVAL, /* 104 */ + EINVAL, /* 105 */ + EINVAL, /* 106 */ + EXDEV, /* ERROR_DISK_CHANGE 107 */ + EAGAIN, /* ERROR_DRIVE_LOCKED 108 */ + EPIPE, /* ERROR_BROKEN_PIPE 109 */ + ENOENT, /* ERROR_OPEN_FAILED 110 */ + EINVAL, /* ERROR_BUFFER_OVERFLOW 111 */ + ENOSPC, /* ERROR_DISK_FULL 112 */ + EMFILE, /* ERROR_NO_MORE_SEARCH_HANDLES 113 */ + EBADF, /* ERROR_INVALID_TARGET_HANDLE 114 */ + EFAULT, /* ERROR_PROTECTION_VIOLATION 115 */ + EINVAL, /* 116 */ + EINVAL, /* 117 */ + EINVAL, /* 118 */ + EINVAL, /* 119 */ + EINVAL, /* 120 */ + EINVAL, /* 121 */ + EINVAL, /* 122 */ + ENOENT, /* ERROR_INVALID_NAME 123 */ + EINVAL, /* 124 */ + EINVAL, /* 125 */ + EINVAL, /* 126 */ + EINVAL, /* ERROR_PROC_NOT_FOUND 127 */ + ECHILD, /* ERROR_WAIT_NO_CHILDREN 128 */ + ECHILD, /* ERROR_CHILD_NOT_COMPLETE 129 */ + EBADF, /* ERROR_DIRECT_ACCESS_HANDLE 130 */ + EINVAL, /* ERROR_NEGATIVE_SEEK 131 */ + ESPIPE, /* ERROR_SEEK_ON_DEVICE 132 */ + EINVAL, /* 133 */ + EINVAL, /* 134 */ + EINVAL, /* 135 */ + EINVAL, /* 136 */ + EINVAL, /* 137 */ + EINVAL, /* 138 */ + EINVAL, /* 139 */ + EINVAL, /* 140 */ + EINVAL, /* 141 */ + EAGAIN, /* ERROR_BUSY_DRIVE 142 */ + EINVAL, /* 143 */ + EINVAL, /* 144 */ + EEXIST, /* ERROR_DIR_NOT_EMPTY 145 */ + EINVAL, /* 146 */ + EINVAL, /* 147 */ + EINVAL, /* 148 */ + EINVAL, /* 149 */ + EINVAL, /* 150 */ + EINVAL, /* 151 */ + EINVAL, /* 152 */ + EINVAL, /* 153 */ + EINVAL, /* 154 */ + EINVAL, /* 155 */ + EINVAL, /* 156 */ + EINVAL, /* 157 */ + EACCES, /* ERROR_NOT_LOCKED 158 */ + EINVAL, /* 159 */ + EINVAL, /* 160 */ + ENOENT, /* ERROR_BAD_PATHNAME 161 */ + EINVAL, /* 162 */ + EINVAL, /* 163 */ + EINVAL, /* 164 */ + EINVAL, /* 165 */ + EINVAL, /* 166 */ + EACCES, /* ERROR_LOCK_FAILED 167 */ + EINVAL, /* 168 */ + EINVAL, /* 169 */ + EINVAL, /* 170 */ + EINVAL, /* 171 */ + EINVAL, /* 172 */ + EINVAL, /* 173 */ + EINVAL, /* 174 */ + EINVAL, /* 175 */ + EINVAL, /* 176 */ + EINVAL, /* 177 */ + EINVAL, /* 178 */ + EINVAL, /* 179 */ + EINVAL, /* 180 */ + EINVAL, /* 181 */ + EINVAL, /* 182 */ + EEXIST, /* ERROR_ALREADY_EXISTS 183 */ + ECHILD, /* ERROR_NO_CHILD_PROCESS 184 */ + EINVAL, /* 185 */ + EINVAL, /* 186 */ + EINVAL, /* 187 */ + EINVAL, /* 188 */ + EINVAL, /* 189 */ + EINVAL, /* 190 */ + EINVAL, /* 191 */ + EINVAL, /* 192 */ + EINVAL, /* 193 */ + EINVAL, /* 194 */ + EINVAL, /* 195 */ + EINVAL, /* 196 */ + EINVAL, /* 197 */ + EINVAL, /* 198 */ + EINVAL, /* 199 */ + EINVAL, /* 200 */ + EINVAL, /* 201 */ + EINVAL, /* 202 */ + EINVAL, /* 203 */ + EINVAL, /* 204 */ + EINVAL, /* 205 */ + ENAMETOOLONG,/* ERROR_FILENAME_EXCED_RANGE 206 */ + EINVAL, /* 207 */ + EINVAL, /* 208 */ + EINVAL, /* 209 */ + EINVAL, /* 210 */ + EINVAL, /* 211 */ + EINVAL, /* 212 */ + EINVAL, /* 213 */ + EINVAL, /* 214 */ + EINVAL, /* 215 */ + EINVAL, /* 216 */ + EINVAL, /* 217 */ + EINVAL, /* 218 */ + EINVAL, /* 219 */ + EINVAL, /* 220 */ + EINVAL, /* 221 */ + EINVAL, /* 222 */ + EINVAL, /* 223 */ + EINVAL, /* 224 */ + EINVAL, /* 225 */ + EINVAL, /* 226 */ + EINVAL, /* 227 */ + EINVAL, /* 228 */ + EINVAL, /* 229 */ + EPIPE, /* ERROR_BAD_PIPE 230 */ + EAGAIN, /* ERROR_PIPE_BUSY 231 */ + EPIPE, /* ERROR_NO_DATA 232 */ + EPIPE, /* ERROR_PIPE_NOT_CONNECTED 233 */ + EINVAL, /* 234 */ + EINVAL, /* 235 */ + EINVAL, /* 236 */ + EINVAL, /* 237 */ + EINVAL, /* 238 */ + EINVAL, /* 239 */ + EINVAL, /* 240 */ + EINVAL, /* 241 */ + EINVAL, /* 242 */ + EINVAL, /* 243 */ + EINVAL, /* 244 */ + EINVAL, /* 245 */ + EINVAL, /* 246 */ + EINVAL, /* 247 */ + EINVAL, /* 248 */ + EINVAL, /* 249 */ + EINVAL, /* 250 */ + EINVAL, /* 251 */ + EINVAL, /* 252 */ + EINVAL, /* 253 */ + EINVAL, /* 254 */ + EINVAL, /* 255 */ + EINVAL, /* 256 */ + EINVAL, /* 257 */ + EINVAL, /* 258 */ + EINVAL, /* 259 */ + EINVAL, /* 260 */ + EINVAL, /* 261 */ + EINVAL, /* 262 */ + EINVAL, /* 263 */ + EINVAL, /* 264 */ + EINVAL, /* 265 */ + EINVAL, /* 266 */ + ENOTDIR /* ERROR_DIRECTORY 267 */ +}; + +/* + * The following table contains the mapping from WinSock errors to + * errno errors. + */ + +static const unsigned char wsaErrorTable[] = { + EWOULDBLOCK, /* WSAEWOULDBLOCK */ + EINPROGRESS, /* WSAEINPROGRESS */ + EALREADY, /* WSAEALREADY */ + ENOTSOCK, /* WSAENOTSOCK */ + EDESTADDRREQ, /* WSAEDESTADDRREQ */ + EMSGSIZE, /* WSAEMSGSIZE */ + EPROTOTYPE, /* WSAEPROTOTYPE */ + ENOPROTOOPT, /* WSAENOPROTOOPT */ + EPROTONOSUPPORT, /* WSAEPROTONOSUPPORT */ + ESOCKTNOSUPPORT, /* WSAESOCKTNOSUPPORT */ + EOPNOTSUPP, /* WSAEOPNOTSUPP */ + EPFNOSUPPORT, /* WSAEPFNOSUPPORT */ + EAFNOSUPPORT, /* WSAEAFNOSUPPORT */ + EADDRINUSE, /* WSAEADDRINUSE */ + EADDRNOTAVAIL, /* WSAEADDRNOTAVAIL */ + ENETDOWN, /* WSAENETDOWN */ + ENETUNREACH, /* WSAENETUNREACH */ + ENETRESET, /* WSAENETRESET */ + ECONNABORTED, /* WSAECONNABORTED */ + ECONNRESET, /* WSAECONNRESET */ + ENOBUFS, /* WSAENOBUFS */ + EISCONN, /* WSAEISCONN */ + ENOTCONN, /* WSAENOTCONN */ + ESHUTDOWN, /* WSAESHUTDOWN */ + ETOOMANYREFS, /* WSAETOOMANYREFS */ + ETIMEDOUT, /* WSAETIMEDOUT */ + ECONNREFUSED, /* WSAECONNREFUSED */ + ELOOP, /* WSAELOOP */ + ENAMETOOLONG, /* WSAENAMETOOLONG */ + EHOSTDOWN, /* WSAEHOSTDOWN */ + EHOSTUNREACH, /* WSAEHOSTUNREACH */ + ENOTEMPTY, /* WSAENOTEMPTY */ + EAGAIN, /* WSAEPROCLIM */ + EUSERS, /* WSAEUSERS */ + EDQUOT, /* WSAEDQUOT */ + ESTALE, /* WSAESTALE */ + EREMOTE /* WSAEREMOTE */ +}; + +/* + *---------------------------------------------------------------------- + * + * TclWinConvertError -- + * + * This routine converts a Win32 error into an errno value. + * + * Results: + * None. + * + * Side effects: + * Sets the errno global variable. + * + *---------------------------------------------------------------------- + */ + +void +TclWinConvertError( + DWORD errCode) /* Win32 error code. */ +{ + 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]); + } + } else { + Tcl_SetErrno(errorTable[errCode]); + } +} + +#ifdef __CYGWIN__ +/* + *---------------------------------------------------------------------- + * + * tclWinDebugPanic -- + * + * Display a message. If a debugger is present, present it directly to + * the debugger, otherwise send it to stderr. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +TCL_NORETURN void +tclWinDebugPanic( + const char *format, ...) +{ +#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 { + vfprintf(stderr, format, argList); + fprintf(stderr, "\n"); + fflush(stderr); + } +# if defined(__GNUC__) + __builtin_trap(); +# else + DebugBreak(); +# endif + abort(); +} +#endif +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * tab-width: 8 + * End: + */ diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c new file mode 100644 index 0000000..01af950 --- /dev/null +++ b/win/tclWinFCmd.c @@ -0,0 +1,1968 @@ +/* + * tclWinFCmd.c + * + * This file implements the Windows specific portion of file manipulation + * subcommands of the "file" command. + * + * Copyright (c) 1996-1998 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tclWinInt.h" + +/* + * The following constants specify the type of callback when + * TraverseWinTree() calls the traverseProc() + */ + +#define DOTREE_PRED 1 /* pre-order directory */ +#define DOTREE_POSTD 2 /* post-order directory */ +#define DOTREE_F 3 /* regular file */ +#define DOTREE_LINK 4 /* symbolic link */ + +/* + * Callbacks for file attributes code. + */ + +static int GetWinFileAttributes(Tcl_Interp *interp, int objIndex, + Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); +static int GetWinFileLongName(Tcl_Interp *interp, int objIndex, + Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); +static int GetWinFileShortName(Tcl_Interp *interp, int objIndex, + Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); +static int SetWinFileAttributes(Tcl_Interp *interp, int objIndex, + Tcl_Obj *fileName, Tcl_Obj *attributePtr); +static int CannotSetAttribute(Tcl_Interp *interp, int objIndex, + Tcl_Obj *fileName, Tcl_Obj *attributePtr); + +/* + * Constants and variables necessary for file attributes subcommand. + */ + +enum { + WIN_ARCHIVE_ATTRIBUTE, + WIN_HIDDEN_ATTRIBUTE, + WIN_LONGNAME_ATTRIBUTE, + WIN_READONLY_ATTRIBUTE, + WIN_SHORTNAME_ATTRIBUTE, + WIN_SYSTEM_ATTRIBUTE +}; + +static const int attributeArray[] = {FILE_ATTRIBUTE_ARCHIVE, FILE_ATTRIBUTE_HIDDEN, + 0, FILE_ATTRIBUTE_READONLY, 0, FILE_ATTRIBUTE_SYSTEM}; + + +const char *const tclpFileAttrStrings[] = { + "-archive", "-hidden", "-longname", "-readonly", + "-shortname", "-system", (char *) NULL +}; + +const TclFileAttrProcs tclpFileAttrProcs[] = { + {GetWinFileAttributes, SetWinFileAttributes}, + {GetWinFileAttributes, SetWinFileAttributes}, + {GetWinFileLongName, CannotSetAttribute}, + {GetWinFileAttributes, SetWinFileAttributes}, + {GetWinFileShortName, CannotSetAttribute}, + {GetWinFileAttributes, SetWinFileAttributes}}; + +/* + * Prototype for the TraverseWinTree callback function. + */ + +typedef int (TraversalProc)(const TCHAR *srcPtr, const TCHAR *dstPtr, + int type, Tcl_DString *errorPtr); + +/* + * Declarations for local functions defined in this file: + */ + +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, + 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, + int type, Tcl_DString *errorPtr); +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, + Tcl_DString *errorPtr); + +/* + *--------------------------------------------------------------------------- + * + * TclpObjRenameFile, DoRenameFile -- + * + * Changes the name of an existing file or directory, from src to dst. + * If src and dst refer to the same file or directory, does nothing and + * returns success. Otherwise if dst already exists, it will be deleted + * and replaced by src subject to the following conditions: + * If src is a directory, dst may be an empty directory. + * If src is a file, dst may be a file. + * In any other situation where dst already exists, the rename will fail. + * + * Results: + * If the file or directory was successfully renamed, returns TCL_OK. + * Otherwise the return value is TCL_ERROR and errno is set to indicate + * the error. Some possible values for errno are: + * + * ENAMETOOLONG: src or dst names are too long. + * EACCES: src or dst parent directory can't be read and/or written. + * EEXIST: dst is a non-empty directory. + * EINVAL: src is a root directory or dst is a subdirectory of src. + * EISDIR: dst is a directory, but src is not. + * ENOENT: src doesn't exist. src or dst is "". + * ENOTDIR: src is a directory, but dst is not. + * EXDEV: src and dst are on different filesystems. + * + * EACCES: exists an open file already referring to src or dst. + * EACCES: src or dst specify the current working directory (NT). + * EACCES: src specifies a char device (nul:, com1:, etc.) + * EEXIST: dst specifies a char device (nul:, com1:, etc.) (NT) + * EACCES: dst specifies a char device (nul:, com1:, etc.) (95) + * + * Side effects: + * The implementation supports cross-filesystem renames of files, but the + * caller should be prepared to emulate cross-filesystem renames of + * directories if errno is EXDEV. + * + *--------------------------------------------------------------------------- + */ + +int +TclpObjRenameFile( + Tcl_Obj *srcPathPtr, + Tcl_Obj *destPathPtr) +{ + return DoRenameFile(Tcl_FSGetNativePath(srcPathPtr), + Tcl_FSGetNativePath(destPathPtr)); +} + +static int +DoRenameFile( + const TCHAR *nativeSrc, /* Pathname of file or dir to be renamed + * (native). */ + const TCHAR *nativeDst) /* New pathname for file or directory + * (native). */ +{ +#if defined(HAVE_NO_SEH) && !defined(_WIN64) + TCLEXCEPTION_REGISTRATION registration; +#endif + DWORD srcAttr, dstAttr; + int retval = -1; + + /* + * The MoveFile API acts differently under Win95/98 and NT WRT NULL and + * "". Avoid passing these values. + */ + + if (nativeSrc == NULL || nativeSrc[0] == '\0' || + nativeDst == NULL || nativeDst[0] == '\0') { + Tcl_SetErrno(ENOENT); + return TCL_ERROR; + } + + /* + * The MoveFile API would throw an exception under NT if one of the + * arguments is a char block device. + */ + +#if defined(HAVE_NO_SEH) && !defined(_WIN64) + /* + * Don't have SEH available, do things the hard way. Note that this needs + * to be one block of asm, to avoid stack imbalance; also, it is illegal + * for one asm block to contain a jump to another. + */ + + __asm__ __volatile__ ( + /* + * Pick up params before messing with the stack. + */ + + "movl %[nativeDst], %%ebx" "\n\t" + "movl %[nativeSrc], %%ecx" "\n\t" + + /* + * Construct an TCLEXCEPTION_REGISTRATION to protect the call to + * MoveFile. + */ + + "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 $0, 0x10(%%edx)" "\n\t" /* status */ + + /* + * Link the TCLEXCEPTION_REGISTRATION on the chain. + */ + + "movl %%edx, %%fs:0" "\n\t" + + /* + * Call MoveFile(nativeSrc, nativeDst) + */ + + "pushl %%ebx" "\n\t" + "pushl %%ecx" "\n\t" + "movl %[moveFile], %%eax" "\n\t" + "call *%%eax" "\n\t" + + /* + * Come here on normal exit. Recover the TCLEXCEPTION_REGISTRATION and + * put the status return from MoveFile into it. + */ + + "movl %%fs:0, %%edx" "\n\t" + "movl %%eax, 0x10(%%edx)" "\n\t" + "jmp 2f" "\n" + + /* + * Come here on an exception. Recover the TCLEXCEPTION_REGISTRATION + */ + + "1:" "\t" + "movl %%fs:0, %%edx" "\n\t" + "movl 0x8(%%edx), %%edx" "\n\t" + + /* + * 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), + [nativeDst] "m" (nativeDst), + [nativeSrc] "m" (nativeSrc), + [moveFile] "r" (MoveFile) + : + "%eax", "%ebx", "%ecx", "%edx", "memory" + ); + if (registration.status != FALSE) { + retval = TCL_OK; + } +#else +#ifndef HAVE_NO_SEH + __try { +#endif + if ((*MoveFile)(nativeSrc, nativeDst) != FALSE) { + retval = TCL_OK; + } +#ifndef HAVE_NO_SEH + } __except (EXCEPTION_EXECUTE_HANDLER) {} +#endif +#endif + + if (retval != -1) { + return retval; + } + + TclWinConvertError(GetLastError()); + + srcAttr = GetFileAttributes(nativeSrc); + dstAttr = GetFileAttributes(nativeDst); + if (srcAttr == 0xffffffff) { + if (GetFullPathName(nativeSrc, 0, NULL, + NULL) >= MAX_PATH) { + errno = ENAMETOOLONG; + return TCL_ERROR; + } + srcAttr = 0; + } + if (dstAttr == 0xffffffff) { + if (GetFullPathName(nativeDst, 0, NULL, + NULL) >= MAX_PATH) { + errno = ENAMETOOLONG; + return TCL_ERROR; + } + dstAttr = 0; + } + + if (errno == EBADF) { + errno = EACCES; + return TCL_ERROR; + } + if (errno == EACCES) { + decode: + if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) { + TCHAR *nativeSrcRest, *nativeDstRest; + const char **srcArgv, **dstArgv; + int size, srcArgc, dstArgc; + TCHAR nativeSrcPath[MAX_PATH]; + TCHAR nativeDstPath[MAX_PATH]; + Tcl_DString srcString, dstString; + const char *src, *dst; + + size = GetFullPathName(nativeSrc, MAX_PATH, + nativeSrcPath, &nativeSrcRest); + if ((size == 0) || (size > MAX_PATH)) { + return TCL_ERROR; + } + size = GetFullPathName(nativeDst, MAX_PATH, + nativeDstPath, &nativeDstRest); + if ((size == 0) || (size > MAX_PATH)) { + return TCL_ERROR; + } + CharLower(nativeSrcPath); + CharLower(nativeDstPath); + + src = Tcl_WinTCharToUtf(nativeSrcPath, -1, &srcString); + dst = Tcl_WinTCharToUtf(nativeDstPath, -1, &dstString); + + /* + * Check whether the destination path is actually inside the + * source path. This is true if the prefix matches, and the next + * character is either end-of-string or a directory separator + */ + + if ((strncmp(src, dst, (size_t) Tcl_DStringLength(&srcString))==0) + && (dst[Tcl_DStringLength(&srcString)] == '\\' + || dst[Tcl_DStringLength(&srcString)] == '/' + || dst[Tcl_DStringLength(&srcString)] == '\0')) { + /* + * Trying to move a directory into itself. + */ + + errno = EINVAL; + Tcl_DStringFree(&srcString); + Tcl_DStringFree(&dstString); + return TCL_ERROR; + } + Tcl_SplitPath(src, &srcArgc, &srcArgv); + Tcl_SplitPath(dst, &dstArgc, &dstArgv); + Tcl_DStringFree(&srcString); + Tcl_DStringFree(&dstString); + + if (srcArgc == 1) { + /* + * They are trying to move a root directory. Whether or not it + * is across filesystems, this cannot be done. + */ + + Tcl_SetErrno(EINVAL); + } else if ((srcArgc > 0) && (dstArgc > 0) && + (strcmp(srcArgv[0], dstArgv[0]) != 0)) { + /* + * If src is a directory and dst filesystem != src filesystem, + * errno should be EXDEV. It is very important to get this + * behavior, so that the caller can respond to a cross + * filesystem rename by simulating it with copy and delete. + * The MoveFile system call already handles the case of moving + * a file between filesystems. + */ + + Tcl_SetErrno(EXDEV); + } + + ckfree(srcArgv); + ckfree(dstArgv); + } + + /* + * Other types of access failure is that dst is a read-only + * filesystem, that an open file referred to src or dest, or that src + * or dest specified the current working directory on the current + * filesystem. EACCES is returned for those cases. + */ + + } else if (Tcl_GetErrno() == EEXIST) { + /* + * Reports EEXIST any time the target already exists. If it makes + * sense, remove the old file and try renaming again. + */ + + if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) { + if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) { + /* + * Overwrite empty dst directory with src directory. The + * following call will remove an empty directory. If it fails, + * it's because it wasn't empty. + */ + + if (DoRemoveJustDirectory(nativeDst, 0, NULL) == TCL_OK) { + /* + * Now that that empty directory is gone, we can try + * renaming again. If that fails, we'll put this empty + * directory back, for completeness. + */ + + if (MoveFile(nativeSrc, + nativeDst) != FALSE) { + return TCL_OK; + } + + /* + * Some new error has occurred. Don't know what it could + * be, but report this one. + */ + + TclWinConvertError(GetLastError()); + CreateDirectory(nativeDst, NULL); + SetFileAttributes(nativeDst, dstAttr); + if (Tcl_GetErrno() == EACCES) { + /* + * Decode the EACCES to a more meaningful error. + */ + + goto decode; + } + } + } else { /* (dstAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */ + Tcl_SetErrno(ENOTDIR); + } + } else { /* (srcAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */ + if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) { + Tcl_SetErrno(EISDIR); + } else { + /* + * Overwrite existing file by: + * + * 1. Rename existing file to temp name. + * 2. Rename old file to new name. + * 3. If success, delete temp file. If failure, put temp file + * back to old name. + */ + + TCHAR *nativeRest, *nativeTmp, *nativePrefix; + int result, size; + TCHAR tempBuf[MAX_PATH]; + + size = GetFullPathName(nativeDst, MAX_PATH, + tempBuf, &nativeRest); + if ((size == 0) || (size > MAX_PATH) || (nativeRest == NULL)) { + return TCL_ERROR; + } + nativeTmp = (TCHAR *) tempBuf; + nativeRest[0] = L'\0'; + + result = TCL_ERROR; + 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 + * other app comes along in the meantime and creates the + * same temp file. + */ + + 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 { + DeleteFile(nativeDst); + MoveFile(nativeTmp, nativeDst); + } + } + + /* + * Can't backup dst file or move src file. Return that + * error. Could happen if an open file refers to dst. + */ + + TclWinConvertError(GetLastError()); + if (Tcl_GetErrno() == EACCES) { + /* + * Decode the EACCES to a more meaningful error. + */ + + goto decode; + } + } + return result; + } + } + } + return TCL_ERROR; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpObjCopyFile, DoCopyFile -- + * + * Copy a single file (not a directory). If dst already exists and is not + * a directory, it is removed. + * + * Results: + * If the file was successfully copied, returns TCL_OK. Otherwise the + * return value is TCL_ERROR and errno is set to indicate the error. + * Some possible values for errno are: + * + * EACCES: src or dst parent directory can't be read and/or written. + * EISDIR: src or dst is a directory. + * ENOENT: src doesn't exist. src or dst is "". + * + * EACCES: exists an open file already referring to dst (95). + * EACCES: src specifies a char device (nul:, com1:, etc.) (NT) + * ENOENT: src specifies a char device (nul:, com1:, etc.) (95) + * + * Side effects: + * It is not an error to copy to a char device. + * + *--------------------------------------------------------------------------- + */ + +int +TclpObjCopyFile( + Tcl_Obj *srcPathPtr, + Tcl_Obj *destPathPtr) +{ + return DoCopyFile(Tcl_FSGetNativePath(srcPathPtr), + Tcl_FSGetNativePath(destPathPtr)); +} + +static int +DoCopyFile( + 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; +#endif + int retval = -1; + + /* + * The CopyFile API acts differently under Win95/98 and NT WRT NULL and + * "". Avoid passing these values. + */ + + if (nativeSrc == NULL || nativeSrc[0] == '\0' || + nativeDst == NULL || nativeDst[0] == '\0') { + Tcl_SetErrno(ENOENT); + return TCL_ERROR; + } + + /* + * The CopyFile API would throw an exception under NT if one of the + * arguments is a char block device. + */ + +#if defined(HAVE_NO_SEH) && !defined(_WIN64) + /* + * Don't have SEH available, do things the hard way. Note that this needs + * to be one block of asm, to avoid stack imbalance; also, it is illegal + * for one asm block to contain a jump to another. + */ + + __asm__ __volatile__ ( + + /* + * Pick up parameters before messing with the stack + */ + + "movl %[nativeDst], %%ebx" "\n\t" + "movl %[nativeSrc], %%ecx" "\n\t" + + /* + * Construct an TCLEXCEPTION_REGISTRATION to protect the call to + * CopyFile. + */ + + "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 $0, 0x10(%%edx)" "\n\t" /* status */ + + /* + * Link the TCLEXCEPTION_REGISTRATION on the chain. + */ + + "movl %%edx, %%fs:0" "\n\t" + + /* + * Call CopyFile(nativeSrc, nativeDst, 0) + */ + + "movl %[copyFile], %%eax" "\n\t" + "pushl $0" "\n\t" + "pushl %%ebx" "\n\t" + "pushl %%ecx" "\n\t" + "call *%%eax" "\n\t" + + /* + * Come here on normal exit. Recover the TCLEXCEPTION_REGISTRATION and + * put the status return from CopyFile into it. + */ + + "movl %%fs:0, %%edx" "\n\t" + "movl %%eax, 0x10(%%edx)" "\n\t" + "jmp 2f" "\n" + + /* + * Come here on an exception. Recover the TCLEXCEPTION_REGISTRATION + */ + + "1:" "\t" + "movl %%fs:0, %%edx" "\n\t" + "movl 0x8(%%edx), %%edx" "\n\t" + + /* + * 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), + [nativeDst] "m" (nativeDst), + [nativeSrc] "m" (nativeSrc), + [copyFile] "r" (CopyFile) + : + "%eax", "%ebx", "%ecx", "%edx", "memory" + ); + if (registration.status != FALSE) { + retval = TCL_OK; + } +#else +#ifndef HAVE_NO_SEH + __try { +#endif + if (CopyFile(nativeSrc, nativeDst, 0) != FALSE) { + retval = TCL_OK; + } +#ifndef HAVE_NO_SEH + } __except (EXCEPTION_EXECUTE_HANDLER) {} +#endif +#endif + + if (retval != -1) { + return retval; + } + + TclWinConvertError(GetLastError()); + if (Tcl_GetErrno() == EBADF) { + Tcl_SetErrno(EACCES); + return TCL_ERROR; + } + if (Tcl_GetErrno() == EACCES) { + DWORD srcAttr, dstAttr; + + srcAttr = GetFileAttributes(nativeSrc); + dstAttr = GetFileAttributes(nativeDst); + if (srcAttr != 0xffffffff) { + if (dstAttr == 0xffffffff) { + dstAttr = 0; + } + if ((srcAttr & FILE_ATTRIBUTE_DIRECTORY) || + (dstAttr & FILE_ATTRIBUTE_DIRECTORY)) { + if (srcAttr & FILE_ATTRIBUTE_REPARSE_POINT) { + /* Source is a symbolic link -- copy it */ + if (TclWinSymLinkCopyDirectory(nativeSrc, nativeDst)==0) { + return TCL_OK; + } + } + Tcl_SetErrno(EISDIR); + } + if (dstAttr & FILE_ATTRIBUTE_READONLY) { + SetFileAttributes(nativeDst, + dstAttr & ~((DWORD)FILE_ATTRIBUTE_READONLY)); + if (CopyFile(nativeSrc, nativeDst, + 0) != FALSE) { + return TCL_OK; + } + + /* + * Still can't copy onto dst. Return that error, and restore + * attributes of dst. + */ + + TclWinConvertError(GetLastError()); + SetFileAttributes(nativeDst, dstAttr); + } + } + } + return TCL_ERROR; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpObjDeleteFile, TclpDeleteFile -- + * + * Removes a single file (not a directory). + * + * Results: + * If the file was successfully deleted, returns TCL_OK. Otherwise the + * return value is TCL_ERROR and errno is set to indicate the error. + * Some possible values for errno are: + * + * EACCES: a parent directory can't be read and/or written. + * EISDIR: path is a directory. + * ENOENT: path doesn't exist or is "". + * + * EACCES: exists an open file already referring to path. + * EACCES: path is a char device (nul:, com1:, etc.) + * + * Side effects: + * The file is deleted, even if it is read-only. + * + *--------------------------------------------------------------------------- + */ + +int +TclpObjDeleteFile( + Tcl_Obj *pathPtr) +{ + return TclpDeleteFile(Tcl_FSGetNativePath(pathPtr)); +} + +int +TclpDeleteFile( + 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 (path == NULL || path[0] == '\0') { + Tcl_SetErrno(ENOENT); + return TCL_ERROR; + } + + if (DeleteFile(path) != FALSE) { + return TCL_OK; + } + TclWinConvertError(GetLastError()); + + if (Tcl_GetErrno() == EACCES) { + 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(path, 0) == 0) { + return TCL_OK; + } + } + + /* + * If we fall through here, it is a directory. + * + * Windows NT reports removing a directory as EACCES instead + * of EISDIR. + */ + + Tcl_SetErrno(EISDIR); + } else if (attr & FILE_ATTRIBUTE_READONLY) { + int res = SetFileAttributes(path, + attr & ~((DWORD) FILE_ATTRIBUTE_READONLY)); + + if ((res != 0) && + (DeleteFile(path) != FALSE)) { + return TCL_OK; + } + TclWinConvertError(GetLastError()); + if (res != 0) { + SetFileAttributes(path, attr); + } + } + } + } else if (Tcl_GetErrno() == ENOENT) { + attr = GetFileAttributes(path); + if (attr != 0xffffffff) { + if (attr & FILE_ATTRIBUTE_DIRECTORY) { + /* + * Windows 95 reports removing a directory as ENOENT instead + * of EISDIR. + */ + + Tcl_SetErrno(EISDIR); + } + } + } else if (Tcl_GetErrno() == EINVAL) { + /* + * Windows NT reports removing a char device as EINVAL instead of + * EACCES. + */ + + Tcl_SetErrno(EACCES); + } + + return TCL_ERROR; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpObjCreateDirectory -- + * + * Creates the specified directory. All parent directories of the + * specified directory must already exist. The directory is automatically + * created with permissions so that user can access the new directory and + * create new files or subdirectories in it. + * + * Results: + * If the directory was successfully created, returns TCL_OK. Otherwise + * the return value is TCL_ERROR and errno is set to indicate the error. + * Some possible values for errno are: + * + * EACCES: a parent directory can't be read and/or written. + * EEXIST: path already exists. + * ENOENT: a parent directory doesn't exist. + * + * Side effects: + * A directory is created. + * + *--------------------------------------------------------------------------- + */ + +int +TclpObjCreateDirectory( + Tcl_Obj *pathPtr) +{ + return DoCreateDirectory(Tcl_FSGetNativePath(pathPtr)); +} + +static int +DoCreateDirectory( + const TCHAR *nativePath) /* Pathname of directory to create (native). */ +{ + if (CreateDirectory(nativePath, NULL) == 0) { + DWORD error = GetLastError(); + + TclWinConvertError(error); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpObjCopyDirectory -- + * + * Recursively copies a directory. The target directory dst must not + * already exist. Note that this function does not merge two directory + * hierarchies, even if the target directory is an an empty directory. + * + * Results: + * If the directory was successfully copied, returns TCL_OK. Otherwise + * the return value is TCL_ERROR, errno is set to indicate the error, and + * the pathname of the file that caused the error is stored in errorPtr. + * See TclpCreateDirectory and TclpCopyFile for a description of possible + * values for errno. + * + * Side effects: + * An exact copy of the directory hierarchy src will be created with the + * name dst. If an error occurs, the error will be returned immediately, + * and remaining files will not be processed. + * + *--------------------------------------------------------------------------- + */ + +int +TclpObjCopyDirectory( + Tcl_Obj *srcPathPtr, + Tcl_Obj *destPathPtr, + Tcl_Obj **errorPtr) +{ + Tcl_DString ds; + Tcl_DString srcString, dstString; + Tcl_Obj *normSrcPtr, *normDestPtr; + int ret; + + normSrcPtr = Tcl_FSGetNormalizedPath(NULL,srcPathPtr); + normDestPtr = Tcl_FSGetNormalizedPath(NULL,destPathPtr); + if ((normSrcPtr == NULL) || (normDestPtr == NULL)) { + return TCL_ERROR; + } + + Tcl_WinUtfToTChar(Tcl_GetString(normSrcPtr), -1, &srcString); + Tcl_WinUtfToTChar(Tcl_GetString(normDestPtr), -1, &dstString); + + ret = TraverseWinTree(TraversalCopy, &srcString, &dstString, &ds); + + Tcl_DStringFree(&srcString); + Tcl_DStringFree(&dstString); + + if (ret != TCL_OK) { + if (!strcmp(Tcl_DStringValue(&ds), TclGetString(normSrcPtr))) { + *errorPtr = srcPathPtr; + } else if (!strcmp(Tcl_DStringValue(&ds), TclGetString(normDestPtr))) { + *errorPtr = destPathPtr; + } else { + *errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1); + } + Tcl_DStringFree(&ds); + Tcl_IncrRefCount(*errorPtr); + } + return ret; +} + +/* + *---------------------------------------------------------------------- + * + * TclpObjRemoveDirectory, DoRemoveDirectory -- + * + * Removes directory (and its contents, if the recursive flag is set). + * + * Results: + * If the directory was successfully removed, returns TCL_OK. Otherwise + * the return value is TCL_ERROR, errno is set to indicate the error, and + * the pathname of the file that caused the error is stored in errorPtr. + * Some possible values for errno are: + * + * EACCES: path directory can't be read and/or written. + * EEXIST: path is a non-empty directory. + * EINVAL: path is root directory or current directory. + * ENOENT: path doesn't exist or is "". + * ENOTDIR: path is not a directory. + * + * EACCES: path is a char device (nul:, com1:, etc.) (95) + * EINVAL: path is a char device (nul:, com1:, etc.) (NT) + * + * Side effects: + * Directory removed. If an error occurs, the error will be returned + * immediately, and remaining files will not be deleted. + * + *---------------------------------------------------------------------- + */ + +int +TclpObjRemoveDirectory( + Tcl_Obj *pathPtr, + int recursive, + Tcl_Obj **errorPtr) +{ + Tcl_DString ds; + Tcl_Obj *normPtr = NULL; + int ret; + + if (recursive) { + /* + * In the recursive case, the string rep is used to construct a + * Tcl_DString which may be used extensively, so we can't optimize + * this case easily. + */ + + Tcl_DString native; + normPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); + if (normPtr == NULL) { + return TCL_ERROR; + } + Tcl_WinUtfToTChar(Tcl_GetString(normPtr), -1, &native); + ret = DoRemoveDirectory(&native, recursive, &ds); + Tcl_DStringFree(&native); + } else { + ret = DoRemoveJustDirectory(Tcl_FSGetNativePath(pathPtr), 0, &ds); + } + + if (ret != TCL_OK) { + if (Tcl_DStringLength(&ds) > 0) { + if (normPtr != NULL && + !strcmp(Tcl_DStringValue(&ds), TclGetString(normPtr))) { + *errorPtr = pathPtr; + } else { + *errorPtr = TclDStringToObj(&ds); + } + Tcl_IncrRefCount(*errorPtr); + } + Tcl_DStringFree(&ds); + } + + return ret; +} + +static int +DoRemoveJustDirectory( + 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. */ + Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free DString + * filled with UTF-8 name of file causing + * error. */ +{ + DWORD attr; + + /* + * The RemoveDirectory API acts differently under Win95/98 and NT WRT NULL + * and "". Avoid passing these values. + */ + + if (nativePath == NULL || nativePath[0] == '\0') { + Tcl_SetErrno(ENOENT); + goto end; + } + + attr = GetFileAttributes(nativePath); + + if (attr & FILE_ATTRIBUTE_REPARSE_POINT) { + /* + * It is a symbolic link - remove it. + */ + if (TclWinSymLinkDelete(nativePath, 0) == 0) { + return TCL_OK; + } + } else { + /* + * Ordinary directory. + */ + + if (RemoveDirectory(nativePath) != FALSE) { + return TCL_OK; + } + } + + TclWinConvertError(GetLastError()); + + if (Tcl_GetErrno() == EACCES) { + attr = GetFileAttributes(nativePath); + if (attr != 0xffffffff) { + if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) { + /* + * Windows 95 reports calling RemoveDirectory on a file as an + * EACCES, not an ENOTDIR. + */ + + Tcl_SetErrno(ENOTDIR); + goto end; + } + + if (attr & FILE_ATTRIBUTE_REPARSE_POINT) { + /* + * It is a symbolic link - remove it. + */ + + if (TclWinSymLinkDelete(nativePath, 1) != 0) { + goto end; + } + } + + if (attr & FILE_ATTRIBUTE_READONLY) { + attr &= ~FILE_ATTRIBUTE_READONLY; + if (SetFileAttributes(nativePath, + attr) == FALSE) { + goto end; + } + if (RemoveDirectory(nativePath) != FALSE) { + return TCL_OK; + } + TclWinConvertError(GetLastError()); + SetFileAttributes(nativePath, + attr | FILE_ATTRIBUTE_READONLY); + } + } + } + + if (Tcl_GetErrno() == ENOTEMPTY) { + /* + * The caller depends on EEXIST to signify that the directory is not + * empty, not ENOTEMPTY. + */ + + Tcl_SetErrno(EEXIST); + } + + if ((ignoreError != 0) && (Tcl_GetErrno() == EEXIST)) { + /* + * If we're being recursive, this error may actually be ok, so we + * don't want to initialise the errorPtr yet. + */ + return TCL_ERROR; + } + + end: + if (errorPtr != NULL) { + char *p; + Tcl_WinTCharToUtf(nativePath, -1, errorPtr); + p = Tcl_DStringValue(errorPtr); + for (; *p; ++p) { + if (*p == '\\') *p = '/'; + } + } + return TCL_ERROR; + +} + +static int +DoRemoveDirectory( + Tcl_DString *pathPtr, /* Pathname of directory to be removed + * (native). */ + int recursive, /* If non-zero, removes directories that are + * nonempty. Otherwise, will only remove empty + * directories. */ + Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free DString + * filled with UTF-8 name of file causing + * error. */ +{ + int res = DoRemoveJustDirectory((const TCHAR *)Tcl_DStringValue(pathPtr), recursive, + errorPtr); + + if ((res == TCL_ERROR) && (recursive != 0) && (Tcl_GetErrno() == EEXIST)) { + /* + * The directory is nonempty, but the recursive flag has been + * specified, so we recursively remove all the files in the directory. + */ + + return TraverseWinTree(TraversalDelete, pathPtr, NULL, errorPtr); + } else { + return res; + } +} + +/* + *--------------------------------------------------------------------------- + * + * TraverseWinTree -- + * + * Traverse directory tree specified by sourcePtr, calling the function + * traverseProc for each file and directory encountered. If destPtr is + * non-null, each of name in the sourcePtr directory is appended to the + * directory specified by destPtr and passed as the second argument to + * traverseProc(). + * + * Results: + * Standard Tcl result. + * + * Side effects: + * None caused by TraverseWinTree, however the user specified + * traverseProc() may change state. If an error occurs, the error will be + * returned immediately, and remaining files will not be processed. + * + *--------------------------------------------------------------------------- + */ + +static int +TraverseWinTree( + TraversalProc *traverseProc,/* Function to call for every file and + * directory in source hierarchy. */ + Tcl_DString *sourcePtr, /* Pathname of source directory to be + * traversed (native). */ + Tcl_DString *targetPtr, /* Pathname of directory to traverse in + * parallel with source directory (native), + * may be NULL. */ + Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free DString + * filled with UTF-8 name of file causing + * error. */ +{ + DWORD sourceAttr; + TCHAR *nativeSource, *nativeTarget, *nativeErrfile; + int result, found, sourceLen, targetLen = 0, oldSourceLen, oldTargetLen; + HANDLE handle; + WIN32_FIND_DATA data; + + nativeErrfile = NULL; + result = TCL_OK; + oldTargetLen = 0; /* lint. */ + + nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr); + nativeTarget = (TCHAR *) + (targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr)); + + oldSourceLen = Tcl_DStringLength(sourcePtr); + sourceAttr = GetFileAttributes(nativeSource); + if (sourceAttr == 0xffffffff) { + nativeErrfile = nativeSource; + goto end; + } + + if (sourceAttr & FILE_ATTRIBUTE_REPARSE_POINT) { + /* + * Process the symbolic link + */ + + return traverseProc(nativeSource, nativeTarget, DOTREE_LINK, + errorPtr); + } + + if ((sourceAttr & FILE_ATTRIBUTE_DIRECTORY) == 0) { + /* + * Process the regular file + */ + + return traverseProc(nativeSource, nativeTarget, DOTREE_F, errorPtr); + } + + Tcl_DStringAppend(sourcePtr, (char *) TEXT("\\*.*"), 4 * sizeof(TCHAR) + 1); + Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1); + + nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr); + handle = FindFirstFile(nativeSource, &data); + if (handle == INVALID_HANDLE_VALUE) { + /* + * Can't read directory. + */ + + TclWinConvertError(GetLastError()); + nativeErrfile = nativeSource; + goto end; + } + + Tcl_DStringSetLength(sourcePtr, oldSourceLen + 1); + Tcl_DStringSetLength(sourcePtr, oldSourceLen); + result = traverseProc(nativeSource, nativeTarget, DOTREE_PRED, + errorPtr); + if (result != TCL_OK) { + FindClose(handle); + return result; + } + + sourceLen = oldSourceLen + sizeof(TCHAR); + Tcl_DStringAppend(sourcePtr, (char *) TEXT("\\"), sizeof(TCHAR) + 1); + Tcl_DStringSetLength(sourcePtr, sourceLen); + if (targetPtr != NULL) { + oldTargetLen = Tcl_DStringLength(targetPtr); + + targetLen = oldTargetLen; + targetLen += sizeof(TCHAR); + Tcl_DStringAppend(targetPtr, (char *) TEXT("\\"), sizeof(TCHAR) + 1); + Tcl_DStringSetLength(targetPtr, targetLen); + } + + found = 1; + for (; found; found = FindNextFile(handle, &data)) { + TCHAR *nativeName; + int len; + + TCHAR *wp = data.cFileName; + if (*wp == '.') { + wp++; + if (*wp == '.') { + wp++; + } + if (*wp == '\0') { + continue; + } + } + nativeName = (TCHAR *) data.cFileName; + len = _tcslen(data.cFileName) * sizeof(TCHAR); + + /* + * Append name after slash, and recurse on the file. + */ + + Tcl_DStringAppend(sourcePtr, (char *) nativeName, len + 1); + Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1); + if (targetPtr != NULL) { + Tcl_DStringAppend(targetPtr, (char *) nativeName, len + 1); + Tcl_DStringSetLength(targetPtr, Tcl_DStringLength(targetPtr) - 1); + } + result = TraverseWinTree(traverseProc, sourcePtr, targetPtr, + errorPtr); + if (result != TCL_OK) { + break; + } + + /* + * Remove name after slash. + */ + + Tcl_DStringSetLength(sourcePtr, sourceLen); + if (targetPtr != NULL) { + Tcl_DStringSetLength(targetPtr, targetLen); + } + } + FindClose(handle); + + /* + * Strip off the trailing slash we added. + */ + + Tcl_DStringSetLength(sourcePtr, oldSourceLen + 1); + Tcl_DStringSetLength(sourcePtr, oldSourceLen); + if (targetPtr != NULL) { + Tcl_DStringSetLength(targetPtr, oldTargetLen + 1); + Tcl_DStringSetLength(targetPtr, oldTargetLen); + } + if (result == TCL_OK) { + /* + * Call traverseProc() on a directory after visiting all the + * files in that directory. + */ + + result = traverseProc((const TCHAR *)Tcl_DStringValue(sourcePtr), + (const TCHAR *)(targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr)), + DOTREE_POSTD, errorPtr); + } + + end: + if (nativeErrfile != NULL) { + TclWinConvertError(GetLastError()); + if (errorPtr != NULL) { + Tcl_WinTCharToUtf(nativeErrfile, -1, errorPtr); + } + result = TCL_ERROR; + } + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TraversalCopy + * + * Called from TraverseUnixTree in order to execute a recursive copy of a + * directory. + * + * Results: + * Standard Tcl result. + * + * Side effects: + * Depending on the value of type, src may be copied to dst. + * + *---------------------------------------------------------------------- + */ + +static int +TraversalCopy( + 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. */ +{ + switch (type) { + case DOTREE_F: + if (DoCopyFile(nativeSrc, nativeDst) == TCL_OK) { + return TCL_OK; + } + break; + case DOTREE_LINK: + if (TclWinSymLinkCopyDirectory(nativeSrc, nativeDst) == TCL_OK) { + return TCL_OK; + } + break; + case DOTREE_PRED: + if (DoCreateDirectory(nativeDst) == TCL_OK) { + DWORD attr = GetFileAttributes(nativeSrc); + + if (SetFileAttributes(nativeDst, + attr) != FALSE) { + return TCL_OK; + } + TclWinConvertError(GetLastError()); + } + break; + case DOTREE_POSTD: + return TCL_OK; + } + + /* + * There shouldn't be a problem with src, because we already checked it to + * get here. + */ + + if (errorPtr != NULL) { + Tcl_WinTCharToUtf(nativeDst, -1, errorPtr); + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * TraversalDelete -- + * + * Called by function TraverseWinTree for every file and directory that + * it encounters in a directory hierarchy. This function unlinks files, + * and removes directories after all the containing files have been + * processed. + * + * Results: + * Standard Tcl result. + * + * Side effects: + * Files or directory specified by src will be deleted. If an error + * occurs, the windows error is converted to a Posix error and errno is + * set accordingly. + * + *---------------------------------------------------------------------- + */ + +static int +TraversalDelete( + 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. */ +{ + switch (type) { + case DOTREE_F: + if (TclpDeleteFile(nativeSrc) == TCL_OK) { + return TCL_OK; + } + break; + case DOTREE_LINK: + if (DoRemoveJustDirectory(nativeSrc, 0, NULL) == TCL_OK) { + return TCL_OK; + } + break; + case DOTREE_PRED: + return TCL_OK; + case DOTREE_POSTD: + if (DoRemoveJustDirectory(nativeSrc, 0, NULL) == TCL_OK) { + return TCL_OK; + } + break; + } + + if (errorPtr != NULL) { + Tcl_WinTCharToUtf(nativeSrc, -1, errorPtr); + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * StatError -- + * + * Sets the object result with the appropriate error. + * + * Results: + * None. + * + * Side effects: + * The interp's object result is set with an error message based on the + * objIndex, fileName and errno. + * + *---------------------------------------------------------------------- + */ + +static void +StatError( + Tcl_Interp *interp, /* The interp that has the error */ + Tcl_Obj *fileName) /* The name of the file which caused the + * error. */ +{ + TclWinConvertError(GetLastError()); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("could not read \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); +} + +/* + *---------------------------------------------------------------------- + * + * GetWinFileAttributes -- + * + * Returns a Tcl_Obj containing the value of a file attribute. This + * routine gets the -hidden, -readonly or -system attribute. + * + * Results: + * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object will + * have ref count 0. If the return value is not TCL_OK, attributePtrPtr + * is not touched. + * + * Side effects: + * A new object is allocated if the file is valid. + * + *---------------------------------------------------------------------- + */ + +static int +GetWinFileAttributes( + Tcl_Interp *interp, /* The interp we are using for errors. */ + int objIndex, /* The index of the attribute. */ + Tcl_Obj *fileName, /* The name of the file. */ + Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ +{ + DWORD result; + const TCHAR *nativeName; + int attr; + + nativeName = Tcl_FSGetNativePath(fileName); + result = GetFileAttributes(nativeName); + + if (result == 0xffffffff) { + StatError(interp, fileName); + return TCL_ERROR; + } + + attr = (int)(result & attributeArray[objIndex]); + if ((objIndex == WIN_HIDDEN_ATTRIBUTE) && (attr != 0)) { + /* + * It is hidden. However there is a bug on some Windows OSes in which + * root volumes (drives) formatted as NTFS are declared hidden when + * they are not (and cannot be). + * + * We test for, and fix that case, here. + */ + + const char *str = TclGetString(fileName); + size_t len = fileName->length; + + if (len < 4) { + if (len == 0) { + /* + * Not sure if this is possible, but we pass it on anyway. + */ + } else if (len == 1 && (str[0] == '/' || str[0] == '\\')) { + /* + * Path is pointing to the root volume. + */ + + attr = 0; + } else if ((str[1] == ':') + && (len == 2 || (str[2] == '/' || str[2] == '\\'))) { + /* + * Path is of the form 'x:' or 'x:/' or 'x:\' + */ + + attr = 0; + } + } + } + + *attributePtrPtr = Tcl_NewBooleanObj(attr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ConvertFileNameFormat -- + * + * Returns a Tcl_Obj containing either the long or short version of the + * file name. + * + * Results: + * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object will + * have ref count 0. If the return value is not TCL_OK, attributePtrPtr + * is not touched. + * + * Warning: if you pass this function a drive name like 'c:' it will + * actually return the current working directory on that drive. To avoid + * this, make sure the drive name ends in a slash, like this 'c:/'. + * + * Side effects: + * A new object is allocated if the file is valid. + * + *---------------------------------------------------------------------- + */ + +static int +ConvertFileNameFormat( + Tcl_Interp *interp, /* The interp we are using for errors. */ + int objIndex, /* The index of the attribute. */ + Tcl_Obj *fileName, /* The name of the file. */ + int longShort, /* 0 to short name, 1 to long name. */ + Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ +{ + int pathc, i; + Tcl_Obj *splitPath; + + splitPath = Tcl_FSSplitPath(fileName, &pathc); + + if (splitPath == NULL || pathc == 0) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read \"%s\": no such file or directory", + Tcl_GetString(fileName))); + errno = ENOENT; + Tcl_PosixError(interp); + } + goto cleanup; + } + + /* + * We will decrement this again at the end. It is safer to do this in + * case any of the calls below retain a reference to splitPath. + */ + + Tcl_IncrRefCount(splitPath); + + for (i = 0; i < pathc; i++) { + Tcl_Obj *elt; + char *pathv; + size_t pathLen; + + Tcl_ListObjIndex(NULL, splitPath, i, &elt); + + pathv = TclGetString(elt); + pathLen = elt->length; + if ((pathv[0] == '/') || ((pathLen == 3) && (pathv[1] == ':')) + || (strcmp(pathv, ".") == 0) || (strcmp(pathv, "..") == 0)) { + /* + * Handle "/", "//machine/export", "c:/", "." or ".." by just + * copying the string literally. Uppercase the drive letter, just + * because it looks better under Windows to do so. + */ + + simple: + /* + * Here we are modifying the string representation in place. + * + * I believe this is legal, since this won't affect any file + * representation this thing may have. + */ + + pathv[0] = (char) Tcl_UniCharToUpper(UCHAR(pathv[0])); + } else { + Tcl_Obj *tempPath; + Tcl_DString ds; + Tcl_DString dsTemp; + const TCHAR *nativeName; + const char *tempString; + WIN32_FIND_DATA data; + HANDLE handle; + DWORD attr; + + tempPath = Tcl_FSJoinPath(splitPath, i+1); + Tcl_IncrRefCount(tempPath); + + /* + * We'd like to call Tcl_FSGetNativePath(tempPath) but that is + * likely to lead to infinite loops. + */ + + Tcl_DStringInit(&ds); + tempString = TclGetString(tempPath); + nativeName = Tcl_WinUtfToTChar(tempString, tempPath->length, &ds); + Tcl_DecrRefCount(tempPath); + handle = FindFirstFile(nativeName, &data); + if (handle == INVALID_HANDLE_VALUE) { + /* + * FindFirstFile() doesn't like root directories. We would + * only get a root directory here if the caller specified "c:" + * or "c:." and the current directory on the drive was the + * root directory + */ + + attr = GetFileAttributes(nativeName); + if ((attr!=0xFFFFFFFF) && (attr & FILE_ATTRIBUTE_DIRECTORY)) { + Tcl_DStringFree(&ds); + goto simple; + } + } + + if (handle == INVALID_HANDLE_VALUE) { + Tcl_DStringFree(&ds); + if (interp != NULL) { + StatError(interp, fileName); + } + goto cleanup; + } + nativeName = data.cAlternateFileName; + if (longShort) { + if (data.cFileName[0] != '\0') { + nativeName = data.cFileName; + } + } else { + if (data.cAlternateFileName[0] == '\0') { + nativeName = (TCHAR *) data.cFileName; + } + } + + /* + * Purify reports a extraneous UMR in Tcl_WinTCharToUtf() trying + * to dereference nativeName as a Unicode string. I have proven to + * myself that purify is wrong by running the following example + * when nativeName == data.w.cAlternateFileName and noting that + * purify doesn't complain about the first line, but does complain + * about the second. + * + * fprintf(stderr, "%d\n", data.w.cAlternateFileName[0]); + * fprintf(stderr, "%d\n", ((WCHAR *) nativeName)[0]); + */ + + Tcl_DStringInit(&dsTemp); + Tcl_WinTCharToUtf(nativeName, -1, &dsTemp); + Tcl_DStringFree(&ds); + + /* + * Deal with issues of tildes being absolute. + */ + + if (Tcl_DStringValue(&dsTemp)[0] == '~') { + TclNewLiteralStringObj(tempPath, "./"); + Tcl_AppendToObj(tempPath, Tcl_DStringValue(&dsTemp), + Tcl_DStringLength(&dsTemp)); + Tcl_DStringFree(&dsTemp); + } else { + tempPath = TclDStringToObj(&dsTemp); + } + Tcl_ListObjReplace(NULL, splitPath, i, 1, 1, &tempPath); + FindClose(handle); + } + } + + *attributePtrPtr = Tcl_FSJoinPath(splitPath, -1); + + if (splitPath != NULL) { + /* + * Unfortunately, the object we will return may have its only refCount + * as part of the list splitPath. This means if we free splitPath, the + * object will disappear. So, we have to be very careful here. + * Unfortunately this means we must manipulate the object's refCount + * directly. + */ + + Tcl_IncrRefCount(*attributePtrPtr); + Tcl_DecrRefCount(splitPath); + --(*attributePtrPtr)->refCount; + } + return TCL_OK; + + cleanup: + if (splitPath != NULL) { + Tcl_DecrRefCount(splitPath); + } + + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * GetWinFileLongName -- + * + * Returns a Tcl_Obj containing the long version of the file name. + * + * Results: + * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object will + * have ref count 0. If the return value is not TCL_OK, attributePtrPtr + * is not touched. + * + * Side effects: + * A new object is allocated if the file is valid. + * + *---------------------------------------------------------------------- + */ + +static int +GetWinFileLongName( + Tcl_Interp *interp, /* The interp we are using for errors. */ + int objIndex, /* The index of the attribute. */ + Tcl_Obj *fileName, /* The name of the file. */ + Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ +{ + return ConvertFileNameFormat(interp, objIndex, fileName, 1, + attributePtrPtr); +} + +/* + *---------------------------------------------------------------------- + * + * GetWinFileShortName -- + * + * Returns a Tcl_Obj containing the short version of the file name. + * + * Results: + * Standard Tcl result and a Tcl_Obj in attributePtrPtr. The object will + * have ref count 0. If the return value is not TCL_OK, attributePtrPtr + * is not touched. + * + * Side effects: + * A new object is allocated if the file is valid. + * + *---------------------------------------------------------------------- + */ + +static int +GetWinFileShortName( + Tcl_Interp *interp, /* The interp we are using for errors. */ + int objIndex, /* The index of the attribute. */ + Tcl_Obj *fileName, /* The name of the file. */ + Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ +{ + return ConvertFileNameFormat(interp, objIndex, fileName, 0, + attributePtrPtr); +} + +/* + *---------------------------------------------------------------------- + * + * SetWinFileAttributes -- + * + * Set the file attributes to the value given by attributePtr. This + * routine sets the -hidden, -readonly, or -system attributes. + * + * Results: + * Standard TCL error. + * + * Side effects: + * The file's attribute is set. + * + *---------------------------------------------------------------------- + */ + +static int +SetWinFileAttributes( + Tcl_Interp *interp, /* The interp we are using for errors. */ + int objIndex, /* The index of the attribute. */ + Tcl_Obj *fileName, /* The name of the file. */ + Tcl_Obj *attributePtr) /* The new value of the attribute. */ +{ + DWORD fileAttributes, old; + int yesNo, result; + const TCHAR *nativeName; + + nativeName = Tcl_FSGetNativePath(fileName); + fileAttributes = old = GetFileAttributes(nativeName); + + if (fileAttributes == 0xffffffff) { + StatError(interp, fileName); + return TCL_ERROR; + } + + result = Tcl_GetBooleanFromObj(interp, attributePtr, &yesNo); + if (result != TCL_OK) { + return result; + } + + if (yesNo) { + fileAttributes |= (attributeArray[objIndex]); + } else { + fileAttributes &= ~(attributeArray[objIndex]); + } + + if ((fileAttributes != old) + && !SetFileAttributes(nativeName, fileAttributes)) { + StatError(interp, fileName); + return TCL_ERROR; + } + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * SetWinFileLongName -- + * + * The attribute in question is a readonly attribute and cannot be set. + * + * Results: + * TCL_ERROR + * + * Side effects: + * The object result is set to a pertinent error message. + * + *---------------------------------------------------------------------- + */ + +static int +CannotSetAttribute( + Tcl_Interp *interp, /* The interp we are using for errors. */ + int objIndex, /* The index of the attribute. */ + Tcl_Obj *fileName, /* The name of the file. */ + Tcl_Obj *attributePtr) /* The new value of the attribute. */ +{ + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot set attribute \"%s\" for file \"%s\": attribute is readonly", + tclpFileAttrStrings[objIndex], Tcl_GetString(fileName))); + errno = EINVAL; + Tcl_PosixError(interp); + return TCL_ERROR; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpObjListVolumes -- + * + * Lists the currently mounted volumes + * + * Results: + * The list of volumes. + * + * Side effects: + * None + * + *--------------------------------------------------------------------------- + */ + +Tcl_Obj * +TclpObjListVolumes(void) +{ + Tcl_Obj *resultPtr, *elemPtr; + char buf[40 * 4]; /* There couldn't be more than 30 drives??? */ + int i; + char *p; + + resultPtr = Tcl_NewObj(); + + /* + * On Win32s: + * GetLogicalDriveStrings() isn't implemented. + * GetLogicalDrives() returns incorrect information. + */ + + if (GetLogicalDriveStringsA(sizeof(buf), buf) == 0) { + /* + * GetVolumeInformation() will detects all drives, but causes + * chattering on empty floppy drives. We only do this if + * GetLogicalDriveStrings() didn't work. It has also been reported + * that on some laptops it takes a while for GetVolumeInformation() to + * return when pinging an empty floppy drive, another reason to try to + * avoid calling it. + */ + + buf[1] = ':'; + buf[2] = '/'; + buf[3] = '\0'; + + for (i = 0; i < 26; i++) { + buf[0] = (char) ('a' + i); + if (GetVolumeInformationA(buf, NULL, 0, NULL, NULL, NULL, NULL, 0) + || (GetLastError() == ERROR_NOT_READY)) { + elemPtr = Tcl_NewStringObj(buf, -1); + Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr); + } + } + } else { + for (p = buf; *p != '\0'; p += 4) { + p[2] = '/'; + elemPtr = Tcl_NewStringObj(p, -1); + Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr); + } + } + + Tcl_IncrRefCount(resultPtr); + return resultPtr; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/win/tclWinFile.c b/win/tclWinFile.c new file mode 100644 index 0000000..700e3c8 --- /dev/null +++ b/win/tclWinFile.c @@ -0,0 +1,3202 @@ +/* + * tclWinFile.c -- + * + * This file contains temporary wrappers around UNIX file handling + * functions. These wrappers map the UNIX functions to Win32 HANDLE-style + * files, which can be manipulated through the Win32 console redirection + * interfaces. + * + * Copyright (c) 1995-1998 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tclWinInt.h" +#include "tclFileSystem.h" +#include <winioctl.h> +#include <shlobj.h> +#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). + */ + +#define POSIX_EPOCH_AS_FILETIME \ + ((Tcl_WideInt) 116444736 * (Tcl_WideInt) 1000000000) + +/* + * Declarations for 'link' related information. This information should come + * with VC++ 6.0, but is not in some older SDKs. In any case it is not well + * documented. + */ + +#ifndef IO_REPARSE_TAG_RESERVED_ONE +# define IO_REPARSE_TAG_RESERVED_ONE 0x000000001 +#endif +#ifndef IO_REPARSE_TAG_RESERVED_RANGE +# define IO_REPARSE_TAG_RESERVED_RANGE 0x000000001 +#endif +#ifndef IO_REPARSE_TAG_VALID_VALUES +# define IO_REPARSE_TAG_VALID_VALUES 0x0E000FFFF +#endif +#ifndef IO_REPARSE_TAG_HSM +# define IO_REPARSE_TAG_HSM 0x0C0000004 +#endif +#ifndef IO_REPARSE_TAG_NSS +# define IO_REPARSE_TAG_NSS 0x080000005 +#endif +#ifndef IO_REPARSE_TAG_NSSRECOVER +# define IO_REPARSE_TAG_NSSRECOVER 0x080000006 +#endif +#ifndef IO_REPARSE_TAG_SIS +# define IO_REPARSE_TAG_SIS 0x080000007 +#endif +#ifndef IO_REPARSE_TAG_DFS +# define IO_REPARSE_TAG_DFS 0x080000008 +#endif + +#ifndef IO_REPARSE_TAG_RESERVED_ZERO +# define IO_REPARSE_TAG_RESERVED_ZERO 0x00000000 +#endif +#ifndef FILE_FLAG_OPEN_REPARSE_POINT +# define FILE_FLAG_OPEN_REPARSE_POINT 0x00200000 +#endif +#ifndef IO_REPARSE_TAG_MOUNT_POINT +# define IO_REPARSE_TAG_MOUNT_POINT 0xA0000003 +#endif +#ifndef IsReparseTagValid +# define IsReparseTagValid(x) \ + (!((x)&~IO_REPARSE_TAG_VALID_VALUES)&&((x)>IO_REPARSE_TAG_RESERVED_RANGE)) +#endif +#ifndef IO_REPARSE_TAG_SYMBOLIC_LINK +# define IO_REPARSE_TAG_SYMBOLIC_LINK IO_REPARSE_TAG_RESERVED_ZERO +#endif +#ifndef FILE_SPECIAL_ACCESS +# define FILE_SPECIAL_ACCESS (FILE_ANY_ACCESS) +#endif +#ifndef FSCTL_SET_REPARSE_POINT +# define FSCTL_SET_REPARSE_POINT \ + CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 41, METHOD_BUFFERED, FILE_SPECIAL_ACCESS) +# define FSCTL_GET_REPARSE_POINT \ + CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 42, METHOD_BUFFERED, FILE_ANY_ACCESS) +# define FSCTL_DELETE_REPARSE_POINT \ + CTL_CODE(FILE_DEVICE_FILE_SYSTEM, 43, METHOD_BUFFERED, FILE_SPECIAL_ACCESS) +#endif +#ifndef INVALID_FILE_ATTRIBUTES +#define INVALID_FILE_ATTRIBUTES ((DWORD)-1) +#endif + +/* + * Maximum reparse buffer info size. The max user defined reparse data is + * 16KB, plus there's a header. + */ + +#define MAX_REPARSE_SIZE 17000 + +/* + * Undocumented REPARSE_MOUNTPOINT_HEADER_SIZE structure definition. This is + * found in winnt.h. + * + * IMPORTANT: caution when using this structure, since the actual structures + * used will want to store a full path in the 'PathBuffer' field, but there + * isn't room (there's only a single WCHAR!). Therefore one must artificially + * create a larger space of memory and then cast it to this type. We use the + * 'DUMMY_REPARSE_BUFFER' struct just below to deal with this problem. + */ + +#define REPARSE_MOUNTPOINT_HEADER_SIZE 8 +#ifndef REPARSE_DATA_BUFFER_HEADER_SIZE +typedef struct _REPARSE_DATA_BUFFER { + DWORD ReparseTag; + WORD ReparseDataLength; + WORD Reserved; + union { + struct { + WORD SubstituteNameOffset; + WORD SubstituteNameLength; + WORD PrintNameOffset; + WORD PrintNameLength; + ULONG Flags; + WCHAR PathBuffer[1]; + } SymbolicLinkReparseBuffer; + struct { + WORD SubstituteNameOffset; + WORD SubstituteNameLength; + WORD PrintNameOffset; + WORD PrintNameLength; + WCHAR PathBuffer[1]; + } MountPointReparseBuffer; + struct { + BYTE DataBuffer[1]; + } GenericReparseBuffer; + }; +} REPARSE_DATA_BUFFER; +#endif + +typedef struct { + REPARSE_DATA_BUFFER dummy; + WCHAR dummyBuf[MAX_PATH * 3]; +} DUMMY_REPARSE_BUFFER; + +/* + * Other typedefs required by this code. + */ + +static time_t ToCTime(FILETIME fileTime); +static void FromCTime(time_t posixTime, FILETIME *fileTime); + +/* + * Declarations for local functions defined in this file: + */ + +static int NativeAccess(const TCHAR *path, int mode); +static int NativeDev(const TCHAR *path); +static int NativeStat(const TCHAR *path, Tcl_StatBuf *statPtr, + int checkLinks); +static unsigned short NativeStatMode(DWORD attr, int checkLinks, + int isExec); +static int NativeIsExec(const TCHAR *path); +static int NativeReadReparse(const TCHAR *LinkDirectory, + REPARSE_DATA_BUFFER *buffer, DWORD desiredAccess); +static int NativeWriteReparse(const TCHAR *LinkDirectory, + REPARSE_DATA_BUFFER *buffer); +static int NativeMatchType(int isDrive, DWORD attr, + const TCHAR *nativeName, Tcl_GlobTypeData *types); +static int WinIsDrive(const char *name, size_t nameLen); +static int WinIsReserved(const char *path); +static Tcl_Obj * WinReadLink(const TCHAR *LinkSource); +static Tcl_Obj * WinReadLinkDirectory(const TCHAR *LinkDirectory); +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, ...); + +/* + *-------------------------------------------------------------------- + * + * WinLink -- + * + * Make a link from source to target. + * + *-------------------------------------------------------------------- + */ + +static int +WinLink( + const TCHAR *linkSourcePath, + const TCHAR *linkTargetPath, + int linkAction) +{ + TCHAR tempFileName[MAX_PATH]; + TCHAR *tempFilePart; + DWORD attr; + + /* + * Get the full path referenced by the target. + */ + + if (!GetFullPathName(linkTargetPath, MAX_PATH, tempFileName, + &tempFilePart)) { + /* + * Invalid file. + */ + + TclWinConvertError(GetLastError()); + return -1; + } + + /* + * Make sure source file doesn't exist. + */ + + attr = GetFileAttributes(linkSourcePath); + if (attr != INVALID_FILE_ATTRIBUTES) { + Tcl_SetErrno(EEXIST); + return -1; + } + + /* + * Get the full path referenced by the source file/directory. + */ + + if (!GetFullPathName(linkSourcePath, MAX_PATH, tempFileName, + &tempFilePart)) { + /* + * Invalid file. + */ + + TclWinConvertError(GetLastError()); + return -1; + } + + /* + * Check the target. + */ + + attr = GetFileAttributes(linkTargetPath); + if (attr == INVALID_FILE_ATTRIBUTES) { + /* + * The target doesn't exist. + */ + + TclWinConvertError(GetLastError()); + } else if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) { + /* + * It is a file. + */ + + if (linkAction & TCL_CREATE_HARD_LINK) { + if (CreateHardLink(linkSourcePath, linkTargetPath, NULL)) { + /* + * Success! + */ + + return 0; + } + + TclWinConvertError(GetLastError()); + } else if (linkAction & TCL_CREATE_SYMBOLIC_LINK) { + /* + * Can't symlink files. + */ + + Tcl_SetErrno(ENOTDIR); + } else { + Tcl_SetErrno(ENODEV); + } + } else { + /* + * We've got a directory. Now check whether what we're trying to do is + * reasonable. + */ + + if (linkAction & TCL_CREATE_SYMBOLIC_LINK) { + return WinSymLinkDirectory(linkSourcePath, linkTargetPath); + + } else if (linkAction & TCL_CREATE_HARD_LINK) { + /* + * Can't hard link directories. + */ + + Tcl_SetErrno(EISDIR); + } else { + Tcl_SetErrno(ENODEV); + } + } + return -1; +} + +/* + *-------------------------------------------------------------------- + * + * WinReadLink -- + * + * What does 'LinkSource' point to? + * + *-------------------------------------------------------------------- + */ + +static Tcl_Obj * +WinReadLink( + const TCHAR *linkSourcePath) +{ + TCHAR tempFileName[MAX_PATH]; + TCHAR *tempFilePart; + DWORD attr; + + /* + * Get the full path referenced by the target. + */ + + if (!GetFullPathName(linkSourcePath, MAX_PATH, tempFileName, + &tempFilePart)) { + /* + * Invalid file. + */ + + TclWinConvertError(GetLastError()); + return NULL; + } + + /* + * Make sure source file does exist. + */ + + attr = GetFileAttributes(linkSourcePath); + if (attr == INVALID_FILE_ATTRIBUTES) { + /* + * The source doesn't exist. + */ + + TclWinConvertError(GetLastError()); + return NULL; + + } else if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) { + /* + * It is a file - this is not yet supported. + */ + + Tcl_SetErrno(ENOTDIR); + return NULL; + } + + return WinReadLinkDirectory(linkSourcePath); +} + +/* + *-------------------------------------------------------------------- + * + * WinSymLinkDirectory -- + * + * This routine creates a NTFS junction, using the undocumented + * FSCTL_SET_REPARSE_POINT structure Win2K uses for mount points and + * junctions. + * + * Assumption that linkTargetPath is a valid, existing directory. + * + * Returns: + * Zero on success. + * + *-------------------------------------------------------------------- + */ + +static int +WinSymLinkDirectory( + const TCHAR *linkDirPath, + const TCHAR *linkTargetPath) +{ + DUMMY_REPARSE_BUFFER dummy; + REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER *) &dummy; + int len; + WCHAR nativeTarget[MAX_PATH]; + WCHAR *loop; + + /* + * Make the native target name. + */ + + memcpy(nativeTarget, L"\\??\\", 4 * sizeof(WCHAR)); + memcpy(nativeTarget + 4, linkTargetPath, + sizeof(WCHAR) * (1+wcslen((WCHAR *) linkTargetPath))); + len = wcslen(nativeTarget); + + /* + * We must have backslashes only. This is VERY IMPORTANT. If we have any + * forward slashes everything appears to work, but the resulting symlink + * is useless! + */ + + for (loop = nativeTarget; *loop != 0; loop++) { + if (*loop == L'/') { + *loop = L'\\'; + } + } + if ((nativeTarget[len-1] == L'\\') && (nativeTarget[len-2] != L':')) { + nativeTarget[len-1] = 0; + } + + /* + * Build the reparse info. + */ + + memset(reparseBuffer, 0, sizeof(DUMMY_REPARSE_BUFFER)); + reparseBuffer->ReparseTag = IO_REPARSE_TAG_MOUNT_POINT; + reparseBuffer->MountPointReparseBuffer.SubstituteNameLength = + wcslen(nativeTarget) * sizeof(WCHAR); + reparseBuffer->Reserved = 0; + reparseBuffer->MountPointReparseBuffer.PrintNameLength = 0; + reparseBuffer->MountPointReparseBuffer.PrintNameOffset = + reparseBuffer->MountPointReparseBuffer.SubstituteNameLength + + sizeof(WCHAR); + memcpy(reparseBuffer->MountPointReparseBuffer.PathBuffer, nativeTarget, + sizeof(WCHAR) + + reparseBuffer->MountPointReparseBuffer.SubstituteNameLength); + reparseBuffer->ReparseDataLength = + reparseBuffer->MountPointReparseBuffer.SubstituteNameLength+12; + + return NativeWriteReparse(linkDirPath, reparseBuffer); +} + +/* + *-------------------------------------------------------------------- + * + * TclWinSymLinkCopyDirectory -- + * + * Copy a Windows NTFS junction. This function assumes that LinkOriginal + * exists and is a valid junction point, and that LinkCopy does not + * exist. + * + * Returns: + * Zero on success. + * + *-------------------------------------------------------------------- + */ + +int +TclWinSymLinkCopyDirectory( + const TCHAR *linkOrigPath, /* Existing junction - reparse point */ + const TCHAR *linkCopyPath) /* Will become a duplicate junction */ +{ + DUMMY_REPARSE_BUFFER dummy; + REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER *) &dummy; + + if (NativeReadReparse(linkOrigPath, reparseBuffer, GENERIC_READ)) { + return -1; + } + return NativeWriteReparse(linkCopyPath, reparseBuffer); +} + +/* + *-------------------------------------------------------------------- + * + * TclWinSymLinkDelete -- + * + * Delete a Windows NTFS junction. Once the junction information is + * deleted, the filesystem object becomes an ordinary directory. Unless + * 'linkOnly' is given, that directory is also removed. + * + * Assumption that LinkOriginal is a valid, existing junction. + * + * Returns: + * Zero on success. + * + *-------------------------------------------------------------------- + */ + +int +TclWinSymLinkDelete( + const TCHAR *linkOrigPath, + int linkOnly) +{ + /* + * It is a symbolic link - remove it. + */ + + DUMMY_REPARSE_BUFFER dummy; + REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER *) &dummy; + HANDLE hFile; + DWORD returnedLength; + + memset(reparseBuffer, 0, sizeof(DUMMY_REPARSE_BUFFER)); + reparseBuffer->ReparseTag = IO_REPARSE_TAG_MOUNT_POINT; + hFile = CreateFile(linkOrigPath, GENERIC_WRITE, 0, NULL, OPEN_EXISTING, + FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL); + + if (hFile != INVALID_HANDLE_VALUE) { + if (!DeviceIoControl(hFile, FSCTL_DELETE_REPARSE_POINT, reparseBuffer, + REPARSE_MOUNTPOINT_HEADER_SIZE,NULL,0,&returnedLength,NULL)) { + /* + * Error setting junction. + */ + + TclWinConvertError(GetLastError()); + CloseHandle(hFile); + } else { + CloseHandle(hFile); + if (!linkOnly) { + RemoveDirectory(linkOrigPath); + } + return 0; + } + } + return -1; +} + +/* + *-------------------------------------------------------------------- + * + * WinReadLinkDirectory -- + * + * This routine reads a NTFS junction, using the undocumented + * FSCTL_GET_REPARSE_POINT structure Win2K uses for mount points and + * junctions. + * + * Assumption that LinkDirectory is a valid, existing directory. + * + * Returns: + * A Tcl_Obj with refCount of 1 (i.e. owned by the caller), or NULL if + * anything went wrong. + * + * In the future we should enhance this to return a path object rather + * than a string. + * + *-------------------------------------------------------------------- + */ + +static Tcl_Obj * +WinReadLinkDirectory( + const TCHAR *linkDirPath) +{ + int attr, len, offset; + DUMMY_REPARSE_BUFFER dummy; + REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER *) &dummy; + Tcl_Obj *retVal; + Tcl_DString ds; + const char *copy; + + attr = GetFileAttributes(linkDirPath); + if (!(attr & FILE_ATTRIBUTE_REPARSE_POINT)) { + goto invalidError; + } + if (NativeReadReparse(linkDirPath, reparseBuffer, 0)) { + return NULL; + } + + switch (reparseBuffer->ReparseTag) { + case 0x80000000|IO_REPARSE_TAG_SYMBOLIC_LINK: + case IO_REPARSE_TAG_SYMBOLIC_LINK: + case IO_REPARSE_TAG_MOUNT_POINT: + /* + * Certain native path representations on Windows have a special + * prefix to indicate that they are to be treated specially. For + * example extremely long paths, or symlinks, or volumes mounted + * inside directories. + * + * There is an assumption in this code that 'wide' interfaces are + * being used (see tclWin32Dll.c), which is true for the only systems + * which support reparse tags at present. If that changes in the + * future, this code will have to be generalised. + */ + + offset = 0; +#ifdef UNICODE + if (reparseBuffer->MountPointReparseBuffer.PathBuffer[0] == L'\\') { + /* + * Check whether this is a mounted volume. + */ + + if (wcsncmp(reparseBuffer->MountPointReparseBuffer.PathBuffer, + L"\\??\\Volume{",11) == 0) { + char drive; + + /* + * There is some confusion between \??\ and \\?\ which we have + * to fix here. It doesn't seem very well documented. + */ + + reparseBuffer->MountPointReparseBuffer.PathBuffer[1]=L'\\'; + + /* + * Check if a corresponding drive letter exists, and use that + * if it is found + */ + + drive = TclWinDriveLetterForVolMountPoint( + reparseBuffer->MountPointReparseBuffer.PathBuffer); + if (drive != -1) { + char driveSpec[3] = { + '\0', ':', '\0' + }; + + driveSpec[0] = drive; + retVal = Tcl_NewStringObj(driveSpec,2); + Tcl_IncrRefCount(retVal); + return retVal; + } + + /* + * This is actually a mounted drive, which doesn't exists as a + * DOS drive letter. This means the path isn't actually a + * link, although we partially treat it like one ('file type' + * will return 'link'), but then the link will actually just + * be treated like an ordinary directory. I don't believe any + * serious inconsistency will arise from this, but it is + * something to be aware of. + */ + + goto invalidError; + } else if (wcsncmp(reparseBuffer->MountPointReparseBuffer + .PathBuffer, L"\\\\?\\",4) == 0) { + /* + * Strip off the prefix. + */ + + offset = 4; + } else if (wcsncmp(reparseBuffer->MountPointReparseBuffer + .PathBuffer, L"\\??\\",4) == 0) { + /* + * Strip off the prefix. + */ + + offset = 4; + } + } +#endif /* UNICODE */ + + Tcl_WinTCharToUtf((const TCHAR *) + reparseBuffer->MountPointReparseBuffer.PathBuffer, + (int) reparseBuffer->MountPointReparseBuffer + .SubstituteNameLength, &ds); + + copy = Tcl_DStringValue(&ds)+offset; + len = Tcl_DStringLength(&ds)-offset; + retVal = Tcl_NewStringObj(copy,len); + Tcl_IncrRefCount(retVal); + Tcl_DStringFree(&ds); + return retVal; + } + + invalidError: + Tcl_SetErrno(EINVAL); + return NULL; +} + +/* + *-------------------------------------------------------------------- + * + * NativeReadReparse -- + * + * Read the junction/reparse information from a given NTFS directory. + * + * Assumption that linkDirPath is a valid, existing directory. + * + * Returns: + * Zero on success. + * + *-------------------------------------------------------------------- + */ + +static int +NativeReadReparse( + const TCHAR *linkDirPath, /* The junction to read */ + REPARSE_DATA_BUFFER *buffer,/* Pointer to buffer. Cannot be NULL */ + DWORD desiredAccess) +{ + HANDLE hFile; + DWORD returnedLength; + + 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) { + /* + * Error creating directory. + */ + + TclWinConvertError(GetLastError()); + return -1; + } + + /* + * Get the link. + */ + + if (!DeviceIoControl(hFile, FSCTL_GET_REPARSE_POINT, NULL, 0, buffer, + sizeof(DUMMY_REPARSE_BUFFER), &returnedLength, NULL)) { + /* + * Error setting junction. + */ + + TclWinConvertError(GetLastError()); + CloseHandle(hFile); + return -1; + } + CloseHandle(hFile); + + if (!IsReparseTagValid(buffer->ReparseTag)) { + Tcl_SetErrno(EINVAL); + return -1; + } + return 0; +} + +/* + *-------------------------------------------------------------------- + * + * NativeWriteReparse -- + * + * Write the reparse information for a given directory. + * + * Assumption that LinkDirectory does not exist. + * + *-------------------------------------------------------------------- + */ + +static int +NativeWriteReparse( + const TCHAR *linkDirPath, + REPARSE_DATA_BUFFER *buffer) +{ + HANDLE hFile; + DWORD returnedLength; + + /* + * Create the directory - it must not already exist. + */ + + if (CreateDirectory(linkDirPath, NULL) == 0) { + /* + * Error creating directory. + */ + + TclWinConvertError(GetLastError()); + return -1; + } + 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. + */ + + TclWinConvertError(GetLastError()); + return -1; + } + + /* + * Set the link. + */ + + if (!DeviceIoControl(hFile, FSCTL_SET_REPARSE_POINT, buffer, + (DWORD) buffer->ReparseDataLength + REPARSE_MOUNTPOINT_HEADER_SIZE, + NULL, 0, &returnedLength, NULL)) { + /* + * Error setting junction. + */ + + TclWinConvertError(GetLastError()); + CloseHandle(hFile); + RemoveDirectory(linkDirPath); + return -1; + } + CloseHandle(hFile); + + /* + * We succeeded. + */ + + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * 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 -- + * + * This function computes the absolute path name of the current + * application. + * + * Results: + * None. + * + * Side effects: + * The computed path is stored. + * + *--------------------------------------------------------------------------- + */ + +void +TclpFindExecutable( + 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. Only if it is NULL, install a new panic handler. + */ + + if (argv0 == NULL) { + Tcl_SetPanicProc(tclWinDebugPanic); + } + +#ifdef UNICODE + GetModuleFileNameW(NULL, wName, MAX_PATH); +#else + GetModuleFileNameA(NULL, name, sizeof(name)); + + /* + * Convert to WCHAR to get out of ANSI codepage + */ + + 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); +} + +/* + *---------------------------------------------------------------------- + * + * TclpMatchInDirectory -- + * + * This routine is used by the globbing code to search a directory for + * all files which match a given pattern. + * + * Results: + * The return value is a standard Tcl result indicating whether an error + * occurred in globbing. Errors are left in interp, good results are + * lappended to resultPtr (which must be a valid object). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclpMatchInDirectory( + Tcl_Interp *interp, /* Interpreter to receive errors. */ + Tcl_Obj *resultPtr, /* List object to lappend results. */ + Tcl_Obj *pathPtr, /* Contains path to directory to search. */ + const char *pattern, /* Pattern to match against. */ + Tcl_GlobTypeData *types) /* Object containing list of acceptable types. + * May be NULL. In particular the directory + * flag is very important. */ +{ + const TCHAR *native; + + if (types != NULL && types->type == TCL_GLOB_TYPE_MOUNT) { + /* + * The native filesystem never adds mounts. + */ + + return TCL_OK; + } + + if (pattern == NULL || (*pattern == '\0')) { + Tcl_Obj *norm = Tcl_FSGetNormalizedPath(NULL, pathPtr); + + if (norm != NULL) { + /* + * Match a single file directly. + */ + + DWORD attr; + WIN32_FILE_ATTRIBUTE_DATA data; + const char *str = TclGetString(norm); + + native = Tcl_FSGetNativePath(pathPtr); + + if (GetFileAttributesEx(native, + GetFileExInfoStandard, &data) != TRUE) { + return TCL_OK; + } + attr = data.dwFileAttributes; + + if (NativeMatchType(WinIsDrive(str,norm->length), attr, native, types)) { + Tcl_ListObjAppendElement(interp, resultPtr, pathPtr); + } + } + return TCL_OK; + } else { + DWORD attr; + HANDLE handle; + WIN32_FIND_DATA data; + const char *dirName; /* UTF-8 dir name, later with pattern + * appended. */ + size_t dirLength; + int matchSpecialDots; + Tcl_DString ds; /* Native encoding of dir, also used + * temporarily for other things. */ + Tcl_DString dsOrig; /* UTF-8 encoding of dir. */ + Tcl_Obj *fileNamePtr; + char lastChar; + + /* + * Get the normalized path representation (the main thing is we dont + * want any '~' sequences). + */ + + fileNamePtr = Tcl_FSGetNormalizedPath(interp, pathPtr); + if (fileNamePtr == NULL) { + return TCL_ERROR; + } + + /* + * Verify that the specified path exists and is actually a directory. + */ + + native = Tcl_FSGetNativePath(pathPtr); + if (native == NULL) { + return TCL_OK; + } + attr = GetFileAttributes(native); + + if ((attr == INVALID_FILE_ATTRIBUTES) + || ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0)) { + return TCL_OK; + } + + /* + * Build up the directory name for searching, including a trailing + * directory separator. + */ + + Tcl_DStringInit(&dsOrig); + dirName = TclGetString(fileNamePtr); + dirLength = fileNamePtr->length; + Tcl_DStringAppend(&dsOrig, dirName, dirLength); + + lastChar = dirName[dirLength -1]; + if ((lastChar != '\\') && (lastChar != '/') && (lastChar != ':')) { + TclDStringAppendLiteral(&dsOrig, "/"); + dirLength++; + } + dirName = Tcl_DStringValue(&dsOrig); + + /* + * We need to check all files in the directory, so we append '*.*' to + * the path, unless the pattern we've been given is rather simple, + * when we can use that instead. + */ + + if (strpbrk(pattern, "[]\\") == NULL) { + /* + * The pattern is a simple one containing just '*' and/or '?'. + * This means we can get the OS to help us, by passing it the + * pattern. + */ + + dirName = Tcl_DStringAppend(&dsOrig, pattern, -1); + } else { + dirName = TclDStringAppendLiteral(&dsOrig, "*.*"); + } + + native = Tcl_WinUtfToTChar(dirName, -1, &ds); + if ((types == NULL) || (types->type != TCL_GLOB_TYPE_DIR)) { + handle = FindFirstFile(native, &data); + } else { + /* + * We can be more efficient, for pure directory requests. + */ + + 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) { + /* + * We used our 'pattern' above, and matched nothing. This + * means we just return TCL_OK, indicating no results found. + */ + + Tcl_DStringFree(&dsOrig); + return TCL_OK; + } + + TclWinConvertError(err); + if (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; + } + Tcl_DStringFree(&ds); + + /* + * We may use this later, so we must restore it to its length + * including the directory delimiter. + */ + + Tcl_DStringSetLength(&dsOrig, dirLength); + + /* + * Check to see if the pattern should match the special . and + * .. names, referring to the current directory, or the directory + * above. We need a special check for this because paths beginning + * with a dot are not considered hidden on Windows, and so otherwise a + * relative glob like 'glob -join * *' will actually return + * './. ../..' etc. + */ + + if ((pattern[0] == '.') + || ((pattern[0] == '\\') && (pattern[1] == '.'))) { + matchSpecialDots = 1; + } else { + matchSpecialDots = 0; + } + + /* + * Now iterate over all of the files in the directory, starting with + * the first one we found. + */ + + do { + const char *utfname; + int checkDrive = 0, isDrive; + DWORD attr; + + native = data.cFileName; + attr = data.dwFileAttributes; + utfname = Tcl_WinTCharToUtf(native, -1, &ds); + + if (!matchSpecialDots) { + /* + * If it is exactly '.' or '..' then we ignore it. + */ + + if ((utfname[0] == '.') && (utfname[1] == '\0' + || (utfname[1] == '.' && utfname[2] == '\0'))) { + Tcl_DStringFree(&ds); + continue; + } + } else if (utfname[0] == '.' && utfname[1] == '.' + && utfname[2] == '\0') { + /* + * Have to check if this is a drive below, so we can correctly + * match 'hidden' and not hidden files. + */ + + checkDrive = 1; + } + + /* + * Check to see if the file matches the pattern. Note that we are + * ignoring the case sensitivity flag because Windows doesn't + * honor case even if the volume is case sensitive. If the volume + * also doesn't preserve case, then we previously returned the + * lower case form of the name. This didn't seem quite right since + * there are non-case-preserving volumes that actually return + * mixed case. So now we are returning exactly what we get from + * the system. + */ + + if (Tcl_StringCaseMatch(utfname, pattern, 1)) { + /* + * If the file matches, then we need to process the remainder + * of the path. + */ + + if (checkDrive) { + const char *fullname = Tcl_DStringAppend(&dsOrig, utfname, + Tcl_DStringLength(&ds)); + + isDrive = WinIsDrive(fullname, Tcl_DStringLength(&dsOrig)); + Tcl_DStringSetLength(&dsOrig, dirLength); + } else { + isDrive = 0; + } + if (NativeMatchType(isDrive, attr, native, types)) { + Tcl_ListObjAppendElement(interp, resultPtr, + TclNewFSPathObj(pathPtr, utfname, + Tcl_DStringLength(&ds))); + } + } + + /* + * Free ds here to ensure that native is valid above. + */ + + Tcl_DStringFree(&ds); + } while (FindNextFile(handle, &data) == TRUE); + + FindClose(handle); + Tcl_DStringFree(&dsOrig); + return TCL_OK; + } +} + +/* + * Does the given path represent a root volume? We need this special case + * because for NTFS root volumes, the getFileAttributesProc returns a 'hidden' + * attribute when it should not. + */ + +static int +WinIsDrive( + const char *name, /* Name (UTF-8) */ + size_t len) /* Length of name */ +{ + int remove = 0; + + while (len > 4) { + if ((name[len-1] != '.' || name[len-2] != '.') + || (name[len-3] != '/' && name[len-3] != '\\')) { + /* + * We don't have '/..' at the end. + */ + + if (remove == 0) { + break; + } + remove--; + while (len > 0) { + len--; + if (name[len] == '/' || name[len] == '\\') { + break; + } + } + if (len < 4) { + len++; + break; + } + } else { + /* + * We do have '/..' + */ + + len -= 3; + remove++; + } + } + + if (len < 4) { + if (len == 0) { + /* + * Not sure if this is possible, but we pass it on anyway. + */ + } else if (len == 1 && (name[0] == '/' || name[0] == '\\')) { + /* + * Path is pointing to the root volume. + */ + + return 1; + } else if ((name[1] == ':') + && (len == 2 || (name[2] == '/' || name[2] == '\\'))) { + /* + * Path is of the form 'x:' or 'x:/' or 'x:\' + */ + + return 1; + } + } + + return 0; +} + +/* + * Does the given path represent a reserved window path name? If not return 0, + * if true, return the number of characters of the path that we actually want + * (not any trailing :). + */ + +static int +WinIsReserved( + const char *path) /* Path in UTF-8 */ +{ + if ((path[0] == 'c' || path[0] == 'C') + && (path[1] == 'o' || path[1] == 'O')) { + if ((path[2] == 'm' || path[2] == 'M') + && path[3] >= '1' && path[3] <= '9') { + /* + * May have match for 'com[1-9]:?', which is a serial port. + */ + + if (path[4] == '\0') { + return 4; + } else if (path [4] == ':' && path[5] == '\0') { + return 4; + } + } else if ((path[2] == 'n' || path[2] == 'N') && path[3] == '\0') { + /* + * Have match for 'con' + */ + + return 3; + } + + } else if ((path[0] == 'l' || path[0] == 'L') + && (path[1] == 'p' || path[1] == 'P') + && (path[2] == 't' || path[2] == 'T')) { + if (path[3] >= '1' && path[3] <= '9') { + /* + * May have match for 'lpt[1-9]:?' + */ + + if (path[4] == '\0') { + return 4; + } else if (path [4] == ':' && path[5] == '\0') { + return 4; + } + } + + } else if (!strcasecmp(path, "prn") || !strcasecmp(path, "nul") + || !strcasecmp(path, "aux")) { + /* + * Have match for 'prn', 'nul' or 'aux'. + */ + + return 3; + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * NativeMatchType -- + * + * This function needs a special case for a path which is a root volume, + * because for NTFS root volumes, the getFileAttributesProc returns a + * 'hidden' attribute when it should not. + * + * We never make any calls to a 'get attributes' routine here, since we + * have arranged things so that our caller already knows such + * information. + * + * Results: + * 0 = file doesn't match + * 1 = file matches + * + *---------------------------------------------------------------------- + */ + +static int +NativeMatchType( + int isDrive, /* Is this a drive. */ + DWORD attr, /* We already know the attributes for the + * file. */ + const TCHAR *nativeName, /* Native path to check. */ + Tcl_GlobTypeData *types) /* Type description to match against. */ +{ + /* + * 'attr' represents the attributes of the file, but we only want to + * retrieve this info if it is absolutely necessary because it is an + * expensive call. Unfortunately, to deal with hidden files properly, we + * must always retrieve it. + */ + + if (types == NULL) { + /* + * If invisible, don't return the file. + */ + + return !(attr & FILE_ATTRIBUTE_HIDDEN && !isDrive); + } + + if (attr & FILE_ATTRIBUTE_HIDDEN && !isDrive) { + /* + * If invisible. + */ + + if ((types->perm == 0) || !(types->perm & TCL_GLOB_PERM_HIDDEN)) { + return 0; + } + } else { + /* + * Visible. + */ + + 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->type & TCL_GLOB_TYPE_DIR) + && (attr & FILE_ATTRIBUTE_DIRECTORY)) { + /* + * Quicker test for directory, which is a common case. + */ + + return 1; + + } else if (types->type != 0) { + unsigned short st_mode; + int isExec = NativeIsExec(nativeName); + + 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)) || +#ifdef S_ISSOCK + ((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 { +#ifdef S_ISLNK + if (types->type & TCL_GLOB_TYPE_LINK) { + st_mode = NativeStatMode(attr, 1, isExec); + if (S_ISLNK(st_mode)) { + return 1; + } + } +#endif /* S_ISLNK */ + return 0; + } + } + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * TclpGetUserHome -- + * + * This function takes the passed in user name and finds the + * corresponding home directory specified in the password file. + * + * Results: + * The result is a pointer to a string specifying the user's home + * directory, or NULL if the user's home directory could not be + * determined. Storage for the result string is allocated in bufferPtr; + * the caller must call Tcl_DStringFree() when the result is no longer + * needed. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +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. */ +{ + const char *result = NULL; + USER_INFO_1 *uiPtr, **uiPtrPtr = &uiPtr; + Tcl_DString ds; + int nameLen = -1; + int badDomain = 0; + char *domain; + WCHAR *wName, *wHomeDir, *wDomain, **wDomainPtr = &wDomain; + WCHAR buf[MAX_PATH]; + + Tcl_DStringInit(bufferPtr); + wDomain = NULL; + domain = strchr(name, '@'); + if (domain != NULL) { + Tcl_DStringInit(&ds); + wName = Tcl_UtfToUniCharDString(domain + 1, -1, &ds); + badDomain = NetGetDCName(NULL, wName, (LPBYTE *) wDomainPtr); + Tcl_DStringFree(&ds); + nameLen = domain - name; + } + if (badDomain == 0) { + Tcl_DStringInit(&ds); + wName = Tcl_UtfToUniCharDString(name, nameLen, &ds); + if (NetUserGetInfo(wDomain, wName, 1, (LPBYTE *) uiPtrPtr) == 0) { + wHomeDir = uiPtr->usri1_home_dir; + if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) { + Tcl_UniCharToUtfDString(wHomeDir, lstrlenW(wHomeDir), + bufferPtr); + } else { + /* + * User exists but has no home dir. Return + * "{GetProfilesDirectory}/<user>". + */ + DWORD i, size = MAX_PATH; + GetProfilesDirectoryW(buf, &size); + for (i = 0; i < size; ++i){ + if (buf[i] == '\\') buf[i] = '/'; + } + Tcl_UniCharToUtfDString(buf, size-1, bufferPtr); + Tcl_DStringAppend(bufferPtr, "/", -1); + Tcl_DStringAppend(bufferPtr, name, -1); + } + result = Tcl_DStringValue(bufferPtr); + NetApiBufferFree((void *) uiPtr); + } + Tcl_DStringFree(&ds); + } + if (wDomain != NULL) { + NetApiBufferFree((void *) wDomain); + } + if (result == NULL) { + /* + * Look in the "Password Lists" section of system.ini for the local + * user. There are also entries in that section that begin with a "*" + * character that are used by Windows for other purposes; ignore user + * names beginning with a "*". + */ + + char buf[MAX_PATH]; + + if (name[0] != '*') { + if (GetPrivateProfileStringA("Password Lists", name, "", buf, + MAX_PATH, "system.ini") > 0) { + /* + * User exists, but there is no such thing as a home directory + * in system.ini. Return "{Windows drive}:/". + */ + + GetWindowsDirectoryA(buf, MAX_PATH); + Tcl_DStringAppend(bufferPtr, buf, 3); + result = Tcl_DStringValue(bufferPtr); + } + } + } + + return result; +} + +/* + *--------------------------------------------------------------------------- + * + * NativeAccess -- + * + * This function replaces the library version of access(), fixing the + * following bugs: + * + * 1. access() returns that all files have execute permission. + * + * Results: + * See access documentation. + * + * Side effects: + * See access documentation. + * + *--------------------------------------------------------------------------- + */ + +static int +NativeAccess( + const TCHAR *nativePath, /* Path of file to access, native encoding. */ + int mode) /* Permission setting. */ +{ + DWORD attr; + + attr = GetFileAttributes(nativePath); + + if (attr == INVALID_FILE_ATTRIBUTES) { + /* + * File might not exist. + */ + + DWORD lasterror = GetLastError(); + if (lasterror != ERROR_SHARING_VIOLATION) { + TclWinConvertError(lasterror); + return -1; + } + } + + if (mode == F_OK) { + /* + * File exists, nothing else to check. + */ + + return 0; + } + + if ((mode & W_OK) + && (attr & FILE_ATTRIBUTE_READONLY) + && !(attr & FILE_ATTRIBUTE_DIRECTORY)) { + /* + * The attributes say the file is not writable. If the file is a + * regular file (i.e., not a directory), then the file is not + * writable, full stop. For directories, the read-only bit is + * (mostly) ignored by Windows, so we can't ascertain anything about + * directory access from the attrib data. However, if we have the + * advanced 'getFileSecurityProc', then more robust ACL checks + * will be done below. + */ + + Tcl_SetErrno(EACCES); + return -1; + } + + if (mode & X_OK) { + if (!(attr & FILE_ATTRIBUTE_DIRECTORY) && !NativeIsExec(nativePath)) { + /* + * It's not a directory and doesn't have the correct extension. + * Therefore it can't be executable + */ + + Tcl_SetErrno(EACCES); + return -1; + } + } + + /* + * It looks as if the permissions are ok, but if we are on NT, 2000 or XP, + * we have a more complex permissions structure so we try to check that. + * The code below is remarkably complex for such a simple thing as finding + * what permissions the OS has set for a file. + */ + +#ifdef UNICODE + { + SECURITY_DESCRIPTOR *sdPtr = NULL; + unsigned long size; + PSID pSid = 0; + BOOL SidDefaulted; + SID_IDENTIFIER_AUTHORITY samba_unmapped = {{0, 0, 0, 0, 0, 22}}; + GENERIC_MAPPING genMap; + HANDLE hToken = NULL; + DWORD desiredAccess = 0, grantedAccess = 0; + BOOL accessYesNo = FALSE; + PRIVILEGE_SET privSet; + DWORD privSetSize = sizeof(PRIVILEGE_SET); + int error; + + /* + * First find out how big the buffer needs to be. + */ + + size = 0; + GetFileSecurity(nativePath, + OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION + | DACL_SECURITY_INFORMATION | LABEL_SECURITY_INFORMATION, + 0, 0, &size); + + /* + * Should have failed with ERROR_INSUFFICIENT_BUFFER + */ + + error = GetLastError(); + if (error != ERROR_INSUFFICIENT_BUFFER) { + /* + * Most likely case is ERROR_ACCESS_DENIED, which we will convert + * to EACCES - just what we want! + */ + + TclWinConvertError((DWORD) error); + return -1; + } + + /* + * Now size contains the size of buffer needed. + */ + + sdPtr = (SECURITY_DESCRIPTOR *) HeapAlloc(GetProcessHeap(), 0, size); + + if (sdPtr == NULL) { + goto accessError; + } + + /* + * Call GetFileSecurity() for real. + */ + + if (!GetFileSecurity(nativePath, + OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION + | DACL_SECURITY_INFORMATION | LABEL_SECURITY_INFORMATION, + sdPtr, size, &size)) { + /* + * Error getting owner SD + */ + + goto accessError; + } + + /* + * As of Samba 3.0.23 (10-Jul-2006), unmapped users and groups are + * assigned to SID domains S-1-22-1 and S-1-22-2, where "22" is the + * top-level authority. If the file owner and group is unmapped then + * the ACL access check below will only test against world access, + * which is likely to be more restrictive than the actual access + * restrictions. Since the ACL tests are more likely wrong than + * right, skip them. Moreover, the unix owner access permissions are + * usually mapped to the Windows attributes, so if the user is the + * file owner then the attrib checks above are correct (as far as they + * go). + */ + + if(!GetSecurityDescriptorOwner(sdPtr,&pSid,&SidDefaulted) || + memcmp(GetSidIdentifierAuthority(pSid),&samba_unmapped, + sizeof(SID_IDENTIFIER_AUTHORITY))==0) { + HeapFree(GetProcessHeap(), 0, sdPtr); + return 0; /* Attrib tests say access allowed. */ + } + + /* + * Perform security impersonation of the user and open the resulting + * thread token. + */ + + if (!ImpersonateSelf(SecurityImpersonation)) { + /* + * Unable to perform security impersonation. + */ + + goto accessError; + } + if (!OpenThreadToken(GetCurrentThread(), + TOKEN_DUPLICATE | TOKEN_QUERY, FALSE, &hToken)) { + /* + * Unable to get current thread's token. + */ + + goto accessError; + } + + RevertToSelf(); + + /* + * Setup desiredAccess according to the access priveleges we are + * checking. + */ + + if (mode & R_OK) { + desiredAccess |= FILE_GENERIC_READ; + } + if (mode & W_OK) { + desiredAccess |= FILE_GENERIC_WRITE; + } + if (mode & X_OK) { + desiredAccess |= FILE_GENERIC_EXECUTE; + } + + memset(&genMap, 0x0, sizeof(GENERIC_MAPPING)); + genMap.GenericRead = FILE_GENERIC_READ; + genMap.GenericWrite = FILE_GENERIC_WRITE; + genMap.GenericExecute = FILE_GENERIC_EXECUTE; + genMap.GenericAll = FILE_ALL_ACCESS; + + /* + * Perform access check using the token. + */ + + if (!AccessCheck(sdPtr, hToken, desiredAccess, + &genMap, &privSet, &privSetSize, &grantedAccess, + &accessYesNo)) { + /* + * Unable to perform access check. + */ + + accessError: + TclWinConvertError(GetLastError()); + if (sdPtr != NULL) { + HeapFree(GetProcessHeap(), 0, sdPtr); + } + if (hToken != NULL) { + CloseHandle(hToken); + } + return -1; + } + + /* + * Clean up. + */ + + HeapFree(GetProcessHeap(), 0, sdPtr); + CloseHandle(hToken); + if (!accessYesNo) { + Tcl_SetErrno(EACCES); + return -1; + } + + } +#endif /* !UNICODE */ + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * NativeIsExec -- + * + * Determines if a path is executable. On windows this is simply defined + * by whether the path ends in a standard executable extension. + * + * Results: + * 1 = executable, 0 = not. + * + *---------------------------------------------------------------------- + */ + +static int +NativeIsExec( + const TCHAR *path) +{ + int len = _tcslen(path); + + if (len < 5) { + return 0; + } + + if (path[len-4] != '.') { + return 0; + } + + if ((_tcsicmp(path+len-3, TEXT("exe")) == 0) + || (_tcsicmp(path+len-3, TEXT("com")) == 0) + || (_tcsicmp(path+len-3, TEXT("cmd")) == 0) + || (_tcsicmp(path+len-3, TEXT("bat")) == 0)) { + return 1; + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclpObjChdir -- + * + * This function replaces the library version of chdir(). + * + * Results: + * See chdir() documentation. + * + * Side effects: + * See chdir() documentation. + * + *---------------------------------------------------------------------- + */ + +int +TclpObjChdir( + Tcl_Obj *pathPtr) /* Path to new working directory. */ +{ + int result; + const TCHAR *nativePath; + + nativePath = Tcl_FSGetNativePath(pathPtr); + + if (!nativePath) { + return -1; + } + result = SetCurrentDirectory(nativePath); + + if (result == 0) { + TclWinConvertError(GetLastError()); + return -1; + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclpGetCwd -- + * + * This function replaces the library version of getcwd(). (Obsolete + * function, only retained for old extensions which may call it + * directly). + * + * Results: + * The result is a pointer to a string specifying the current directory, + * or NULL if the current directory could not be determined. If NULL is + * returned, an error message is left in the interp's result. Storage for + * the result string is allocated in bufferPtr; the caller must call + * Tcl_DStringFree() when the result is no longer needed. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +const char * +TclpGetCwd( + Tcl_Interp *interp, /* If non-NULL, used for error reporting. */ + Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with + * name of current directory. */ +{ + TCHAR buffer[MAX_PATH]; + char *p; + WCHAR *native; + + if (GetCurrentDirectory(MAX_PATH, buffer) == 0) { + TclWinConvertError(GetLastError()); + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error getting working directory name: %s", + Tcl_PosixError(interp))); + } + return NULL; + } + + /* + * Watch for the weird Windows c:\\UNC syntax. + */ + + 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. + */ + + for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) { + if (*p == '\\') { + *p = '/'; + } + } + return Tcl_DStringValue(bufferPtr); +} + +int +TclpObjStat( + Tcl_Obj *pathPtr, /* Path of file to stat. */ + Tcl_StatBuf *statPtr) /* Filled with results of stat call. */ +{ + /* + * Ensure correct file sizes by forcing the OS to write any pending data + * to disk. This is done only for channels which are dirty, i.e. have been + * written to since the last flush here. + */ + + TclWinFlushDirtyChannels(); + + return NativeStat(Tcl_FSGetNativePath(pathPtr), statPtr, 0); +} + +/* + *---------------------------------------------------------------------- + * + * NativeStat -- + * + * This function replaces the library version of stat(), fixing the + * following bugs: + * + * 1. stat("c:") returns an error. + * 2. Borland stat() return time in GMT instead of localtime. + * 3. stat("\\server\mount") would return error. + * 4. Accepts slashes or backslashes. + * 5. st_dev and st_rdev were wrong for UNC paths. + * + * Results: + * See stat documentation. + * + * Side effects: + * See stat documentation. + * + *---------------------------------------------------------------------- + */ + +static int +NativeStat( + const TCHAR *nativePath, /* Path of file to stat */ + Tcl_StatBuf *statPtr, /* Filled with results of stat call. */ + int checkLinks) /* If non-zero, behave like 'lstat' */ +{ + DWORD attr; + int dev, nlink = 1; + 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 + * fileHandle to read more information (nlink, ino) than we can get from + * 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 = CreateFile(nativePath, GENERIC_READ, + FILE_SHARE_READ | FILE_SHARE_WRITE, NULL, OPEN_EXISTING, + FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OPEN_REPARSE_POINT, NULL); + + if (fileHandle != INVALID_HANDLE_VALUE) { + BY_HANDLE_FILE_INFORMATION data; + + if (GetFileInformationByHandle(fileHandle,&data) != TRUE) { + 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); + + /* + * On Unix, for directories, nlink apparently depends on the number of + * files in the directory. We could calculate that, but it would be a + * bit of a performance penalty, I think. Hence we just use what + * Windows gives us, which is the same as Unix for files, at least. + */ + + nlink = data.nNumberOfLinks; + + /* + * Unfortunately our stat definition's inode field (unsigned short) + * will throw away most of the precision we have here, which means we + * can't rely on inode as a unique identifier of a file. We'd really + * like to do something like how we handle 'st_size'. + */ + + inode = data.nFileIndexHigh | data.nFileIndexLow; + } else { + /* + * Fall back on the less capable routines. This means no nlink or ino. + */ + + WIN32_FILE_ATTRIBUTE_DATA data; + + if (GetFileAttributesEx(nativePath, + GetFileExInfoStandard, &data) != TRUE) { + HANDLE hFind; + WIN32_FIND_DATA ffd; + DWORD lasterror = GetLastError(); + + if (lasterror != ERROR_SHARING_VIOLATION) { + TclWinConvertError(lasterror); + return -1; + } + hFind = FindFirstFile(nativePath, &ffd); + if (hFind == INVALID_HANDLE_VALUE) { + TclWinConvertError(GetLastError()); + return -1; + } + memcpy(&data, &ffd, sizeof(data)); + FindClose(hFind); + } + + 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); + } + + 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; + statPtr->st_mode = mode; + statPtr->st_nlink = nlink; + statPtr->st_uid = 0; + statPtr->st_gid = 0; + statPtr->st_rdev = (dev_t) dev; + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * NativeDev -- + * + * Calculate just the 'st_dev' field of a 'stat' structure. + * + *---------------------------------------------------------------------- + */ + +static int +NativeDev( + const TCHAR *nativePath) /* Full path of file to stat */ +{ + int dev; + Tcl_DString ds; + TCHAR nativeFullPath[MAX_PATH]; + TCHAR *nativePart; + const char *fullPath; + + GetFullPathName(nativePath, MAX_PATH, nativeFullPath, &nativePart); + fullPath = Tcl_WinTCharToUtf(nativeFullPath, -1, &ds); + + if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) { + const char *p; + DWORD dw; + const TCHAR *nativeVol; + Tcl_DString volString; + + p = strchr(fullPath + 2, '\\'); + p = strchr(p + 1, '\\'); + if (p == NULL) { + /* + * Add terminating backslash to fullpath or GetVolumeInformation() + * won't work. + */ + + fullPath = TclDStringAppendLiteral(&ds, "\\"); + p = fullPath + Tcl_DStringLength(&ds); + } else { + p++; + } + nativeVol = Tcl_WinUtfToTChar(fullPath, p - fullPath, &volString); + dw = (DWORD) -1; + GetVolumeInformation(nativeVol, NULL, 0, &dw, NULL, NULL, NULL, 0); + + /* + * GetFullPathName() turns special devices like "NUL" into "\\.\NUL", + * but GetVolumeInformation() returns failure for "\\.\NUL". This will + * cause "NUL" to get a drive number of -1, which makes about as much + * sense as anything since the special devices don't live on any + * drive. + */ + + dev = dw; + Tcl_DStringFree(&volString); + } else if ((fullPath[0] != '\0') && (fullPath[1] == ':')) { + dev = Tcl_UniCharToLower(fullPath[0]) - 'a'; + } else { + dev = -1; + } + Tcl_DStringFree(&ds); + + return dev; +} + +/* + *---------------------------------------------------------------------- + * + * NativeStatMode -- + * + * Calculate just the 'st_mode' field of a 'stat' structure. + * + * In many places we don't need the full stat structure, and it's much + * faster just to calculate these pieces, if that's all we need. + * + *---------------------------------------------------------------------- + */ + +static unsigned short +NativeStatMode( + DWORD attr, + int checkLinks, + int isExec) +{ + int mode; + + if (checkLinks && (attr & FILE_ATTRIBUTE_REPARSE_POINT)) { + /* + * It is a link. + */ + + mode = S_IFLNK; + } else { + mode = (attr & FILE_ATTRIBUTE_DIRECTORY) ? S_IFDIR|S_IEXEC : S_IFREG; + } + mode |= (attr & FILE_ATTRIBUTE_READONLY) ? S_IREAD : S_IREAD|S_IWRITE; + if (isExec) { + mode |= S_IEXEC; + } + + /* + * Propagate the S_IREAD, S_IWRITE, S_IEXEC bits to the group and other + * positions. + */ + + mode |= (mode & (S_IREAD|S_IWRITE|S_IEXEC)) >> 3; + mode |= (mode & (S_IREAD|S_IWRITE|S_IEXEC)) >> 6; + return (unsigned short) mode; +} + +/* + *------------------------------------------------------------------------ + * + * ToCTime -- + * + * Converts a Windows FILETIME to a time_t in UTC. + * + * Results: + * Returns the count of seconds from the Posix epoch. + * + *------------------------------------------------------------------------ + */ + +static time_t +ToCTime( + FILETIME fileTime) /* UTC time */ +{ + LARGE_INTEGER convertedTime; + + convertedTime.LowPart = fileTime.dwLowDateTime; + convertedTime.HighPart = (LONG) fileTime.dwHighDateTime; + + return (time_t) ((convertedTime.QuadPart - + (Tcl_WideInt) POSIX_EPOCH_AS_FILETIME) / (Tcl_WideInt) 10000000); +} + +/* + *------------------------------------------------------------------------ + * + * FromCTime -- + * + * Converts a time_t to a Windows FILETIME + * + * Results: + * Returns the count of 100-ns ticks seconds from the Windows epoch. + * + *------------------------------------------------------------------------ + */ + +static void +FromCTime( + time_t posixTime, + FILETIME *fileTime) /* UTC Time */ +{ + LARGE_INTEGER convertedTime; + + convertedTime.QuadPart = ((LONGLONG) posixTime) * 10000000 + + POSIX_EPOCH_AS_FILETIME; + fileTime->dwLowDateTime = convertedTime.LowPart; + fileTime->dwHighDateTime = convertedTime.HighPart; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpGetNativeCwd -- + * + * This function replaces the library version of getcwd(). + * + * Results: + * The input and output are filesystem paths in native form. The result + * is either the given clientData, if the working directory hasn't + * changed, or a new clientData (owned by our caller), giving the new + * native path, or NULL if the current directory could not be determined. + * If NULL is returned, the caller can examine the standard posix error + * codes to determine the cause of the problem. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +ClientData +TclpGetNativeCwd( + ClientData clientData) +{ + TCHAR buffer[MAX_PATH]; + + if (GetCurrentDirectory(MAX_PATH, buffer) == 0) { + TclWinConvertError(GetLastError()); + return NULL; + } + + if (clientData != NULL) { + if (_tcscmp((const TCHAR*)clientData, buffer) == 0) { + return clientData; + } + } + + return TclNativeDupInternalRep(buffer); +} + +int +TclpObjAccess( + Tcl_Obj *pathPtr, + int mode) +{ + return NativeAccess(Tcl_FSGetNativePath(pathPtr), mode); +} + +int +TclpObjLstat( + Tcl_Obj *pathPtr, + Tcl_StatBuf *statPtr) +{ + /* + * Ensure correct file sizes by forcing the OS to write any pending data + * to disk. This is done only for channels which are dirty, i.e. have been + * written to since the last flush here. + */ + + TclWinFlushDirtyChannels(); + + return NativeStat(Tcl_FSGetNativePath(pathPtr), statPtr, 1); +} + +#ifdef S_IFLNK +Tcl_Obj * +TclpObjLink( + Tcl_Obj *pathPtr, + Tcl_Obj *toPtr, + int linkAction) +{ + if (toPtr != NULL) { + int res; + const TCHAR *LinkTarget; + const TCHAR *LinkSource = Tcl_FSGetNativePath(pathPtr); + Tcl_Obj *normalizedToPtr = Tcl_FSGetNormalizedPath(NULL, toPtr); + + if (normalizedToPtr == NULL) { + return NULL; + } + + LinkTarget = Tcl_FSGetNativePath(normalizedToPtr); + + if (LinkSource == NULL || LinkTarget == NULL) { + return NULL; + } + res = WinLink(LinkSource, LinkTarget, linkAction); + if (res == 0) { + return toPtr; + } else { + return NULL; + } + } else { + const TCHAR *LinkSource = Tcl_FSGetNativePath(pathPtr); + + if (LinkSource == NULL) { + return NULL; + } + return WinReadLink(LinkSource); + } +} +#endif /* S_IFLNK */ + +/* + *--------------------------------------------------------------------------- + * + * TclpFilesystemPathType -- + * + * This function is part of the native filesystem support, and returns + * the path type of the given path. Returns NTFS or FAT or whatever is + * returned by the 'volume information' proc. + * + * Results: + * NULL at present. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +Tcl_Obj * +TclpFilesystemPathType( + Tcl_Obj *pathPtr) +{ +#define VOL_BUF_SIZE 32 + int found; + TCHAR volType[VOL_BUF_SIZE]; + char *firstSeparator; + const char *path; + Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr); + + if (normPath == NULL) { + return NULL; + } + path = Tcl_GetString(normPath); + if (path == NULL) { + return NULL; + } + + firstSeparator = strchr(path, '/'); + if (firstSeparator == NULL) { + 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 = GetVolumeInformation(Tcl_FSGetNativePath(driveName), + NULL, 0, NULL, NULL, NULL, volType, VOL_BUF_SIZE); + Tcl_DecrRefCount(driveName); + } + + if (found == 0) { + return NULL; + } else { + Tcl_DString ds; + + Tcl_WinTCharToUtf(volType, -1, &ds); + return TclDStringToObj(&ds); + } +#undef VOL_BUF_SIZE +} + +/* + * This define can be turned on to experiment with a different way of + * normalizing paths (using a different Windows API). Unfortunately the new + * path seems to take almost exactly the same amount of time as the old path! + * The primary time taken by normalization is in + * GetFileAttributesEx/FindFirstFile or GetFileAttributesEx/GetLongPathName. + * Conversion to/from native is not a significant factor at all. + * + * Also, since we have to check for symbolic links (reparse points) then we + * have to call GetFileAttributes on each path segment anyway, so there's no + * benefit to doing anything clever there. + */ + +/* #define TclNORM_LONG_PATH */ + +/* + *--------------------------------------------------------------------------- + * + * TclpObjNormalizePath -- + * + * This function scans through a path specification and replaces it, in + * place, with a normalized version. This means using the 'longname', and + * expanding any symbolic links contained within the path. + * + * Results: + * The new 'nextCheckpoint' value, giving as far as we could understand + * in the path. + * + * Side effects: + * The pathPtr string, which must contain a valid path, is possibly + * modified in place. + * + *--------------------------------------------------------------------------- + */ + +int +TclpObjNormalizePath( + Tcl_Interp *interp, + Tcl_Obj *pathPtr, + int nextCheckpoint) +{ + char *lastValidPathEnd = NULL; + Tcl_DString dsNorm; /* This will hold the normalized string. */ + char *path, *currentPathEndPosition; + Tcl_Obj *temp = NULL; + int isDrive = 1; + Tcl_DString ds; /* Some workspace. */ + + Tcl_DStringInit(&dsNorm); + path = Tcl_GetString(pathPtr); + + currentPathEndPosition = path + nextCheckpoint; + if (*currentPathEndPosition == '/') { + currentPathEndPosition++; + } + while (1) { + char cur = *currentPathEndPosition; + + if ((cur=='/' || cur==0) && (path != currentPathEndPosition)) { + /* + * Reached directory separator, or end of string. + */ + + WIN32_FILE_ATTRIBUTE_DATA data; + const TCHAR *nativePath = Tcl_WinUtfToTChar(path, + currentPathEndPosition - path, &ds); + + if (GetFileAttributesEx(nativePath, + GetFileExInfoStandard, &data) != TRUE) { + /* + * 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++) { + WCHAR wc = ((WCHAR *) nativePath)[i]; + + if (wc >= L'a') { + wc -= (L'a' - L'A'); + ((WCHAR *) nativePath)[i] = wc; + } + } + Tcl_DStringAppend(&dsNorm, + (const char *)nativePath, + (int)(sizeof(WCHAR) * len)); + lastValidPathEnd = currentPathEndPosition; + } else if (nextCheckpoint == 0) { + /* Path starts with a drive designation + * that's not actually on the system. + * We still must normalize up past the + * first separator. [Bug 3603434] */ + currentPathEndPosition++; + } + } + Tcl_DStringFree(&ds); + break; + } + + /* + * 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. + */ + + if (cur != 0 && !isDrive && + data.dwFileAttributes & FILE_ATTRIBUTE_REPARSE_POINT){ + Tcl_Obj *to = WinReadLinkDirectory(nativePath); + + if (to != NULL) { + /* + * Read the reparse point ok. Now, reparse points need + * not be normalized, otherwise we could use: + * + * Tcl_GetStringFromObj(to, &pathLen); + * nextCheckpoint = pathLen; + * + * So, instead we have to start from the beginning. + */ + + nextCheckpoint = 0; + Tcl_AppendToObj(to, currentPathEndPosition, -1); + + /* + * Convert link to forward slashes. + */ + + for (path = Tcl_GetString(to); *path != 0; path++) { + if (*path == '\\') { + *path = '/'; + } + } + path = Tcl_GetString(to); + currentPathEndPosition = path + nextCheckpoint; + if (temp != NULL) { + Tcl_DecrRefCount(temp); + } + temp = to; + + /* + * Reset variables so we can restart normalization. + */ + + isDrive = 1; + Tcl_DStringFree(&dsNorm); + Tcl_DStringFree(&ds); + continue; + } + } + +#ifndef TclNORM_LONG_PATH + /* + * Now we convert the tail of the current path to its 'long + * form', and append it to 'dsNorm' which holds the current + * normalized path + */ + + if (isDrive) { + WCHAR drive = ((WCHAR *) nativePath)[0]; + + if (drive >= L'a') { + drive -= (L'a' - L'A'); + ((WCHAR *) nativePath)[0] = drive; + } + Tcl_DStringAppend(&dsNorm, (const char *)nativePath, + Tcl_DStringLength(&ds)); + } else { + char *checkDots = NULL; + + if (lastValidPathEnd[1] == '.') { + checkDots = lastValidPathEnd + 1; + while (checkDots < currentPathEndPosition) { + if (*checkDots != '.') { + checkDots = NULL; + break; + } + checkDots++; + } + } + if (checkDots != NULL) { + int dotLen = currentPathEndPosition-lastValidPathEnd; + + /* + * Path is just dots. We shouldn't really ever see a + * path like that. However, to be nice we at least + * don't mangle the path - we just add the dots as a + * path segment and continue. + */ + + Tcl_DStringAppend(&dsNorm, ((const char *)nativePath) + + Tcl_DStringLength(&ds) + - (dotLen * sizeof(TCHAR)), + (int)(dotLen * sizeof(TCHAR))); + } else { + /* + * Normal path. + */ + + 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; + + 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, + (const char *) nativeName, + (int) (wcslen(nativeName)*sizeof(WCHAR))); + } + } + } +#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. + */ + + isDrive = 0; + } + currentPathEndPosition++; + +#ifdef TclNORM_LONG_PATH + /* + * Convert the entire known path to long form. + */ + + if (1) { + WCHAR wpath[MAX_PATH]; + const TCHAR *nativePath = + Tcl_WinUtfToTChar(path, lastValidPathEnd - path, &ds); + DWORD wpathlen = GetLongPathNameProc(nativePath, + (TCHAR *) wpath, MAX_PATH); + + /* + * We have to make the drive letter uppercase. + */ + + if (wpath[0] >= L'a') { + wpath[0] -= (L'a' - L'A'); + } + Tcl_DStringAppend(&dsNorm, (const char *) wpath, + wpathlen * sizeof(WCHAR)); + Tcl_DStringFree(&ds); + } +#endif /* TclNORM_LONG_PATH */ + } + + /* + * Common code path for all Windows platforms. + */ + + nextCheckpoint = currentPathEndPosition - path; + if (lastValidPathEnd != NULL) { + /* + * Concatenate the normalized string in dsNorm with the tail of the + * path which we didn't recognise. The string in dsNorm is in the + * native encoding, so we have to convert it to Utf. + */ + + Tcl_WinTCharToUtf((const TCHAR *) Tcl_DStringValue(&dsNorm), + Tcl_DStringLength(&dsNorm), &ds); + nextCheckpoint = Tcl_DStringLength(&ds); + if (*lastValidPathEnd != 0) { + /* + * Not the end of the string. + */ + + char *path; + Tcl_Obj *tmpPathPtr; + + tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), + nextCheckpoint); + Tcl_AppendToObj(tmpPathPtr, lastValidPathEnd, -1); + path = TclGetString(tmpPathPtr); + Tcl_SetStringObj(pathPtr, path, tmpPathPtr->length); + Tcl_DecrRefCount(tmpPathPtr); + } else { + /* + * End of string was reached above. + */ + + Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&ds), nextCheckpoint); + } + Tcl_DStringFree(&ds); + } + Tcl_DStringFree(&dsNorm); + + /* + * This must be done after we are totally finished with 'path' as we are + * sharing the same underlying string. + */ + + if (temp != NULL) { + Tcl_DecrRefCount(temp); + } + + return nextCheckpoint; +} + +/* + *--------------------------------------------------------------------------- + * + * TclWinVolumeRelativeNormalize -- + * + * Only Windows has volume-relative paths. These paths are rather rare, + * but it is nice if Tcl can handle them. It is much better if we can + * handle them here, rather than in the native fs code, because we really + * need to have a real absolute path just below. + * + * We do not let this block compile on non-Windows platforms because the + * test suite's manual forcing of tclPlatform can otherwise cause this + * code path to be executed, causing various errors because + * volume-relative paths really do not exist. + * + * Results: + * A valid normalized path. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +Tcl_Obj * +TclWinVolumeRelativeNormalize( + Tcl_Interp *interp, + const char *path, + Tcl_Obj **useThisCwdPtr) +{ + Tcl_Obj *absolutePath, *useThisCwd; + + useThisCwd = Tcl_FSGetCwd(interp); + if (useThisCwd == NULL) { + return NULL; + } + + if (path[0] == '/') { + /* + * Path of form /foo/bar which is a path in the root directory of the + * current volume. + */ + + const char *drive = Tcl_GetString(useThisCwd); + + absolutePath = Tcl_NewStringObj(drive,2); + Tcl_AppendToObj(absolutePath, path, -1); + Tcl_IncrRefCount(absolutePath); + + /* + * We have a refCount on the cwd. + */ + } else { + /* + * Path of form C:foo/bar, but this only makes sense if the cwd is + * also on drive C. + */ + + const char *drive = TclGetString(useThisCwd); + size_t cwdLen = useThisCwd->length; + char drive_cur = path[0]; + + if (drive_cur >= 'a') { + drive_cur -= ('a' - 'A'); + } + if (drive[0] == drive_cur) { + absolutePath = Tcl_DuplicateObj(useThisCwd); + + /* + * We have a refCount on the cwd, which we will release later. + */ + + if (drive[cwdLen-1] != '/' && (path[2] != '\0')) { + /* + * Only add a trailing '/' if needed, which is if there isn't + * one already, and if we are going to be adding some more + * characters. + */ + + Tcl_AppendToObj(absolutePath, "/", 1); + } + } else { + Tcl_DecrRefCount(useThisCwd); + useThisCwd = NULL; + + /* + * The path is not in the current drive, but is volume-relative. + * The way Tcl 8.3 handles this is that it treats such a path as + * relative to the root of the drive. We therefore behave the same + * here. This behaviour is, however, different to that of the + * windows command-line. If we want to fix this at some point in + * the future (at the expense of a behaviour change to Tcl), we + * could use the '_dgetdcwd' Win32 API to get the drive's cwd. + */ + + absolutePath = Tcl_NewStringObj(path, 2); + Tcl_AppendToObj(absolutePath, "/", 1); + } + Tcl_IncrRefCount(absolutePath); + Tcl_AppendToObj(absolutePath, path+2, -1); + } + *useThisCwdPtr = useThisCwd; + return absolutePath; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpNativeToNormalized -- + * + * Convert native format to a normalized path object, with refCount of + * zero. + * + * Currently assumes all native paths are actually normalized already, so + * if the path given is not normalized this will actually just convert to + * a valid string path, but not necessarily a normalized one. + * + * Results: + * A valid normalized path. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +Tcl_Obj * +TclpNativeToNormalized( + ClientData clientData) +{ + Tcl_DString ds; + Tcl_Obj *objPtr; + int len; + char *copy, *p; + + Tcl_WinTCharToUtf((const TCHAR *) clientData, -1, &ds); + copy = Tcl_DStringValue(&ds); + len = Tcl_DStringLength(&ds); + + /* + * Certain native path representations on Windows have this special prefix + * to indicate that they are to be treated specially. For example + * extremely long paths, or symlinks. + */ + + if (*copy == '\\') { + if (0 == strncmp(copy,"\\??\\",4)) { + copy += 4; + len -= 4; + } else if (0 == strncmp(copy,"\\\\?\\",4)) { + copy += 4; + len -= 4; + } + } + + /* + * Ensure we are using forward slashes only. + */ + + for (p = copy; *p != '\0'; p++) { + if (*p == '\\') { + *p = '/'; + } + } + + objPtr = Tcl_NewStringObj(copy,len); + Tcl_DStringFree(&ds); + + return objPtr; +} + +/* + *--------------------------------------------------------------------------- + * + * TclNativeCreateNativeRep -- + * + * Create a native representation for the given path. + * + * Results: + * The nativePath representation. + * + * Side effects: + * Memory will be allocated. The path may need to be normalized. + * + *--------------------------------------------------------------------------- + */ + +ClientData +TclNativeCreateNativeRep( + Tcl_Obj *pathPtr) +{ + WCHAR *nativePathPtr = NULL; + const char *str; + Tcl_Obj *validPathPtr; + size_t len; + WCHAR *wp; + + if (TclFSCwdIsNative()) { + /* + * The cwd is native, which means we can use the translated path + * without worrying about normalization (this will also usually be + * shorter so the utf-to-external conversion will be somewhat faster). + */ + + validPathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); + if (validPathPtr == NULL) { + return NULL; + } + /* refCount of validPathPtr was already incremented in Tcl_FSGetTranslatedPath */ + } else { + /* + * Make sure the normalized path is set. + */ + + validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); + if (validPathPtr == NULL) { + return NULL; + } + /* validPathPtr returned from Tcl_FSGetNormalizedPath is owned by Tcl, so incr refCount here */ + Tcl_IncrRefCount(validPathPtr); + } + + str = Tcl_GetString(validPathPtr); + len = validPathPtr->length; + + if (strlen(str)!=(unsigned int)len) { + /* String contains NUL-bytes. This is invalid. */ + goto done; + } + /* For a reserved device, strip a possible postfix ':' */ + len = WinIsReserved(str); + if (len == 0) { + /* Let MultiByteToWideChar check for other invalid sequences, like + * 0xC0 0x80 (== overlong NUL). See bug [3118489]: NUL in filenames */ + len = MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, 0, 0); + if (len==0) { + goto done; + } + } + /* Overallocate 6 chars, making some room for extended paths */ + wp = nativePathPtr = ckalloc( (len+6) * sizeof(WCHAR) ); + if (nativePathPtr==0) { + goto done; + } + MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, nativePathPtr, len+1); + /* + ** If path starts with "//?/" or "\\?\" (extended path), translate + ** any slashes to backslashes but leave the '?' intact + */ + if ((str[0]=='\\' || str[0]=='/') && (str[1]=='\\' || str[1]=='/') + && str[2]=='?' && (str[3]=='\\' || str[3]=='/')) { + wp[0] = wp[1] = wp[3] = '\\'; + str += 4; + wp += 4; + } + /* + ** If there is no "\\?\" prefix but there is a drive or UNC + ** path prefix and the path is larger than MAX_PATH chars, + ** no Win32 API function can handle that unless it is + ** prefixed with the extended path prefix. See: + ** <http://msdn.microsoft.com/en-us/library/aa365247(VS.85).aspx#maxpath> + **/ + if (((str[0]>='A'&&str[0]<='Z') || (str[0]>='a'&&str[0]<='z')) + && str[1]==':') { + if (wp==nativePathPtr && len>MAX_PATH && (str[2]=='\\' || str[2]=='/')) { + memmove(wp+4, wp, len*sizeof(WCHAR)); + memcpy(wp, L"\\\\?\\", 4*sizeof(WCHAR)); + wp += 4; + } + /* + ** If (remainder of) path starts with "<drive>:", + ** leave the ':' intact. + */ + wp += 2; + } else if (wp==nativePathPtr && len>MAX_PATH + && (str[0]=='\\' || str[0]=='/') + && (str[1]=='\\' || str[1]=='/') && str[2]!='?') { + memmove(wp+6, wp, len*sizeof(WCHAR)); + memcpy(wp, L"\\\\?\\UNC", 7*sizeof(WCHAR)); + wp += 7; + } + /* + ** In the remainder of the path, translate invalid characters to + ** characters in the Unicode private use area. + */ + while (*wp != '\0') { + if ((*wp < ' ') || wcschr(L"\"*:<>?|", *wp)) { + *wp |= 0xF000; + } else if (*wp == '/') { + *wp = '\\'; + } + ++wp; + } + + done: + + TclDecrRefCount(validPathPtr); + return nativePathPtr; +} + +/* + *--------------------------------------------------------------------------- + * + * TclNativeDupInternalRep -- + * + * Duplicate the native representation. + * + * Results: + * The copied native representation, or NULL if it is not possible to + * copy the representation. + * + * Side effects: + * Memory allocation for the copy. + * + *--------------------------------------------------------------------------- + */ + +ClientData +TclNativeDupInternalRep( + ClientData clientData) +{ + char *copy; + size_t len; + + if (clientData == NULL) { + return NULL; + } + + len = sizeof(TCHAR) * (_tcslen((const TCHAR *) clientData) + 1); + + copy = ckalloc(len); + memcpy(copy, clientData, len); + return copy; +} + +/* + *--------------------------------------------------------------------------- + * + * TclpUtime -- + * + * Set the modification date for a file. + * + * Results: + * 0 on success, -1 on error. + * + * Side effects: + * Sets errno to a representation of any Windows problem that's observed + * in the process. + * + *--------------------------------------------------------------------------- + */ + +int +TclpUtime( + Tcl_Obj *pathPtr, /* File to modify */ + struct utimbuf *tval) /* New modification date structure */ +{ + int res = 0; + HANDLE fileHandle; + const TCHAR *native; + DWORD attr = 0; + DWORD flags = FILE_ATTRIBUTE_NORMAL; + FILETIME lastAccessTime, lastModTime; + + FromCTime(tval->actime, &lastAccessTime); + FromCTime(tval->modtime, &lastModTime); + + native = Tcl_FSGetNativePath(pathPtr); + + attr = GetFileAttributes(native); + + if (attr != INVALID_FILE_ATTRIBUTES && attr & FILE_ATTRIBUTE_DIRECTORY) { + flags = FILE_FLAG_BACKUP_SEMANTICS; + } + + /* + * We use the native APIs (not 'utime') because there are some daylight + * savings complications that utime gets wrong. + */ + + fileHandle = CreateFile(native, FILE_WRITE_ATTRIBUTES, 0, NULL, + OPEN_EXISTING, flags, NULL); + + if (fileHandle == INVALID_HANDLE_VALUE || + !SetFileTime(fileHandle, NULL, &lastAccessTime, &lastModTime)) { + TclWinConvertError(GetLastError()); + res = -1; + } + if (fileHandle != INVALID_HANDLE_VALUE) { + CloseHandle(fileHandle); + } + return res; +} + +/* + *--------------------------------------------------------------------------- + * + * 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 + * fill-column: 78 + * End: + */ diff --git a/win/tclWinInit.c b/win/tclWinInit.c new file mode 100644 index 0000000..c590865 --- /dev/null +++ b/win/tclWinInit.c @@ -0,0 +1,734 @@ +/* + * tclWinInit.c -- + * + * Contains the Windows-specific interpreter initialization functions. + * + * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 1998-1999 by Scriptics Corporation. + * All rights reserved. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tclWinInt.h" +#include <winnt.h> +#include <winbase.h> +#include <lmcons.h> + +/* + * GetUserName() is found in advapi32.dll + */ +#ifdef _MSC_VER +# pragma comment(lib, "advapi32.lib") +#endif + +/* + * The following declaration is a workaround for some Microsoft brain damage. + * The SYSTEM_INFO structure is different in various releases, even though the + * layout is the same. So we overlay our own structure on top of it so we can + * access the interesting slots in a uniform way. + */ + +typedef struct { + WORD wProcessorArchitecture; + WORD wReserved; +} OemId; + +/* + * The following macros are missing from some versions of winnt.h. + */ + +#ifndef PROCESSOR_ARCHITECTURE_INTEL +#define PROCESSOR_ARCHITECTURE_INTEL 0 +#endif +#ifndef PROCESSOR_ARCHITECTURE_MIPS +#define PROCESSOR_ARCHITECTURE_MIPS 1 +#endif +#ifndef PROCESSOR_ARCHITECTURE_ALPHA +#define PROCESSOR_ARCHITECTURE_ALPHA 2 +#endif +#ifndef PROCESSOR_ARCHITECTURE_PPC +#define PROCESSOR_ARCHITECTURE_PPC 3 +#endif +#ifndef PROCESSOR_ARCHITECTURE_SHX +#define PROCESSOR_ARCHITECTURE_SHX 4 +#endif +#ifndef PROCESSOR_ARCHITECTURE_ARM +#define PROCESSOR_ARCHITECTURE_ARM 5 +#endif +#ifndef PROCESSOR_ARCHITECTURE_IA64 +#define PROCESSOR_ARCHITECTURE_IA64 6 +#endif +#ifndef PROCESSOR_ARCHITECTURE_ALPHA64 +#define PROCESSOR_ARCHITECTURE_ALPHA64 7 +#endif +#ifndef PROCESSOR_ARCHITECTURE_MSIL +#define PROCESSOR_ARCHITECTURE_MSIL 8 +#endif +#ifndef PROCESSOR_ARCHITECTURE_AMD64 +#define PROCESSOR_ARCHITECTURE_AMD64 9 +#endif +#ifndef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64 +#define PROCESSOR_ARCHITECTURE_IA32_ON_WIN64 10 +#endif +#ifndef PROCESSOR_ARCHITECTURE_UNKNOWN +#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. + */ + + +#define NUMPLATFORMS 4 +static const char *const platforms[NUMPLATFORMS] = { + "Win32s", "Windows 95", "Windows NT", "Windows CE" +}; + +#define NUMPROCESSORS 11 +static const char *const processors[NUMPROCESSORS] = { + "intel", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil", + "amd64", "ia32_on_win64" +}; + +/* + * The default directory in which the init.tcl file is expected to be found. + */ + +static TclInitProcessGlobalValueProc InitializeDefaultLibraryDir; +static ProcessGlobalValue defaultLibraryDir = + {0, 0, NULL, NULL, InitializeDefaultLibraryDir, NULL, NULL}; + +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); + +/* + *--------------------------------------------------------------------------- + * + * TclpInitPlatform -- + * + * Initialize all the platform-dependant things like signals, + * floating-point error handling and sockets. + * + * Called at process initialization time. + * + * Results: + * None. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +void +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); + +#ifdef STATIC_BUILD + /* + * If we are in a statically linked executable, then we need to explicitly + * initialize the Windows function tables here since DllMain() will not be + * invoked. + */ + + TclWinInit(GetModuleHandle(NULL)); +#endif + + /* + * Fill available functions depending on windows version + */ + handle = GetModuleHandle(TEXT("KERNEL32")); + tclWinProcs.cancelSynchronousIo = + (BOOL (WINAPI *)(HANDLE)) GetProcAddress(handle, + "CancelSynchronousIo"); +} + +/* + *------------------------------------------------------------------------- + * + * TclpInitLibraryPath -- + * + * This is the fallback routine that sets the library path if the + * application has not set one by the first time it is needed. + * + * Results: + * None. + * + * Side effects: + * Sets the library path to an initial value. + * + *------------------------------------------------------------------------- + */ + +void +TclpInitLibraryPath( + char **valuePtr, + size_t *lengthPtr, + Tcl_Encoding *encodingPtr) +{ +#define LIBRARY_SIZE 64 + Tcl_Obj *pathPtr; + char installLib[LIBRARY_SIZE]; + const char *bytes; + + pathPtr = Tcl_NewObj(); + + /* + * Initialize the substring used when locating the script library. The + * installLib variable computes the script library path relative to the + * installed DLL. + */ + + sprintf(installLib, "lib/tcl%s", TCL_VERSION); + + /* + * Look for the library relative to the TCL_LIBRARY env variable. If the + * last dirname in the TCL_LIBRARY path does not match the last dirname in + * the installLib variable, use the last dir name of installLib in + * addition to the orginal TCL_LIBRARY path. + */ + + AppendEnvironment(pathPtr, installLib); + + /* + * Look for the library in its default location. + */ + + Tcl_ListObjAppendElement(NULL, pathPtr, + TclGetProcessGlobalValue(&defaultLibraryDir)); + + /* + * Look for the library in its source checkout location. + */ + + Tcl_ListObjAppendElement(NULL, pathPtr, + TclGetProcessGlobalValue(&sourceLibraryDir)); + + *encodingPtr = NULL; + bytes = TclGetString(pathPtr); + *lengthPtr = pathPtr->length; + *valuePtr = ckalloc(*lengthPtr + 1); + memcpy(*valuePtr, bytes, *lengthPtr + 1); + Tcl_DecrRefCount(pathPtr); +} + +/* + *--------------------------------------------------------------------------- + * + * AppendEnvironment -- + * + * Append the value of the TCL_LIBRARY environment variable onto the path + * pointer. If the env variable points to another version of tcl (e.g. + * "tcl7.6") also append the path to this version (e.g., + * "tcl7.6/../tcl8.2") + * + * Results: + * None. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static void +AppendEnvironment( + Tcl_Obj *pathPtr, + 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; + char *shortlib; + + /* + * The shortlib value needs to be the tail component of the lib path. For + * example, "lib/tcl8.4" -> "tcl8.4" while "usr/share/tcl8.5" -> "tcl8.5". + */ + + for (shortlib = (char *) &lib[strlen(lib)-1]; shortlib>lib ; shortlib--) { + if (*shortlib == '/') { + if ((unsigned)(shortlib - lib) == strlen(lib) - 1) { + Tcl_Panic("last character in lib cannot be '/'"); + } + shortlib++; + break; + } + } + if (shortlib == lib) { + Tcl_Panic("no '/' character found in lib"); + } + + /* + * The "L" preceeding the TCL_LIBRARY string is used to tell VC++ that + * this is a unicode string. + */ + + if (GetEnvironmentVariableW(L"TCL_LIBRARY", wBuf, MAX_PATH) == 0) { + buf[0] = '\0'; + GetEnvironmentVariableA("TCL_LIBRARY", buf, MAX_PATH); + } else { + ToUtf(wBuf, buf); + } + + if (buf[0] != '\0') { + objPtr = Tcl_NewStringObj(buf, -1); + Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); + + TclWinNoBackslash(buf); + Tcl_SplitPath(buf, &pathc, &pathv); + + /* + * The lstrcmpi() will work even if pathv[pathc-1] is random UTF-8 + * chars because I know shortlib is ascii. + */ + + if ((pathc > 0) && (lstrcmpiA(shortlib, pathv[pathc - 1]) != 0)) { + /* + * TCL_LIBRARY is set but refers to a different tcl installation + * than the current version. Try fiddling with the specified + * directory to make it refer to this installation by removing the + * old "tclX.Y" and substituting the current version string. + */ + + pathv[pathc - 1] = shortlib; + Tcl_DStringInit(&ds); + (void) Tcl_JoinPath(pathc, pathv, &ds); + objPtr = TclDStringToObj(&ds); + } else { + objPtr = Tcl_NewStringObj(buf, -1); + } + Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); + ckfree(pathv); + } +} + +/* + *--------------------------------------------------------------------------- + * + * InitializeDefaultLibraryDir -- + * + * Locate the Tcl script library default location relative to the + * location of the Tcl DLL. + * + * Results: + * None. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static void +InitializeDefaultLibraryDir( + char **valuePtr, + size_t *lengthPtr, + Tcl_Encoding *encodingPtr) +{ + HMODULE hModule = TclWinGetTclInstance(); + WCHAR wName[MAX_PATH + LIBRARY_SIZE]; + char name[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX]; + char *end, *p; + + if (GetModuleFileNameW(hModule, wName, MAX_PATH) == 0) { + GetModuleFileNameA(hModule, name, MAX_PATH); + } else { + ToUtf(wName, name); + } + + end = strrchr(name, '\\'); + *end = '\0'; + p = strrchr(name, '\\'); + if (p != NULL) { + end = p; + } + *end = '\\'; + + TclWinNoBackslash(name); + sprintf(end + 1, "lib/tcl%s", TCL_VERSION); + *lengthPtr = strlen(name); + *valuePtr = ckalloc(*lengthPtr + 1); + *encodingPtr = NULL; + memcpy(*valuePtr, name, *lengthPtr + 1); +} + +/* + *--------------------------------------------------------------------------- + * + * InitializeSourceLibraryDir -- + * + * Locate the Tcl script library default location relative to the + * location of the Tcl DLL as it exists in the build output directory + * associated with the source checkout. + * + * Results: + * None. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static void +InitializeSourceLibraryDir( + char **valuePtr, + size_t *lengthPtr, + Tcl_Encoding *encodingPtr) +{ + HMODULE hModule = TclWinGetTclInstance(); + WCHAR wName[MAX_PATH + LIBRARY_SIZE]; + char name[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX]; + char *end, *p; + + if (GetModuleFileNameW(hModule, wName, MAX_PATH) == 0) { + GetModuleFileNameA(hModule, name, MAX_PATH); + } else { + ToUtf(wName, name); + } + + end = strrchr(name, '\\'); + *end = '\0'; + p = strrchr(name, '\\'); + if (p != NULL) { + end = p; + } + *end = '\\'; + + TclWinNoBackslash(name); + sprintf(end + 1, "../library"); + *lengthPtr = strlen(name); + *valuePtr = ckalloc(*lengthPtr + 1); + *encodingPtr = NULL; + memcpy(*valuePtr, name, *lengthPtr + 1); +} + +/* + *--------------------------------------------------------------------------- + * + * ToUtf -- + * + * Convert a char string to a UTF string. + * + * Results: + * None. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +static int +ToUtf( + const WCHAR *wSrc, + char *dst) +{ + char *start; + + start = dst; + while (*wSrc != '\0') { + dst += Tcl_UniCharToUtf(*wSrc, dst); + wSrc++; + } + *dst = '\0'; + return (int) (dst - start); +} + +/* + *--------------------------------------------------------------------------- + * + * TclpSetInitialEncodings -- + * + * Based on the locale, determine the encoding of the operating system + * and the default encoding for newly opened files. + * + * Called at process initialization time, and part way through startup, + * we verify that the initial encodings were correctly setup. Depending + * on Tcl's environment, there may not have been enough information first + * time through (above). + * + * Results: + * None. + * + * Side effects: + * The Tcl library path is converted from native encoding to UTF-8, on + * the first call, and the encodings may be changed on first or second + * call. + * + *--------------------------------------------------------------------------- + */ + +void +TclpSetInitialEncodings(void) +{ + Tcl_DString encodingName; + + TclpSetInterfaces(); + Tcl_SetSystemEncoding(NULL, + Tcl_GetEncodingNameFromEnvironment(&encodingName)); + Tcl_DStringFree(&encodingName); +} + +void TclWinSetInterfaces( + int dummy) /* Not used. */ +{ + TclpSetInterfaces(); +} + +const char * +Tcl_GetEncodingNameFromEnvironment( + Tcl_DString *bufPtr) +{ + Tcl_DStringInit(bufPtr); + Tcl_DStringSetLength(bufPtr, 2+TCL_INTEGER_SPACE); + wsprintfA(Tcl_DStringValue(bufPtr), "cp%d", GetACP()); + Tcl_DStringSetLength(bufPtr, strlen(Tcl_DStringValue(bufPtr))); + return Tcl_DStringValue(bufPtr); +} + +/* + *--------------------------------------------------------------------------- + * + * TclpSetVariables -- + * + * Performs platform-specific interpreter initialization related to the + * tcl_platform and env variables, and other platform-specific things. + * + * Results: + * None. + * + * Side effects: + * Sets "tcl_platform", and "env(HOME)" Tcl variables. + * + *---------------------------------------------------------------------- + */ + +void +TclpSetVariables( + Tcl_Interp *interp) /* Interp to initialize. */ +{ + const char *ptr; + char buffer[TCL_INTEGER_SPACE * 2]; + union { + SYSTEM_INFO info; + OemId oemId; + } sys; + static OSVERSIONINFOW osInfo; + static int osInfoInitialized = 0; + Tcl_DString ds; + TCHAR szUserName[UNLEN+1]; + DWORD cchUserNameLen = UNLEN; + + Tcl_SetVar2Ex(interp, "tclDefaultLibrary", NULL, + TclGetProcessGlobalValue(&defaultLibraryDir), TCL_GLOBAL_ONLY); + + if (!osInfoInitialized) { + HMODULE handle = GetModuleHandle(TEXT("NTDLL")); + int(__stdcall *getversion)(void *) = + (int(__stdcall *)(void *)) GetProcAddress(handle, "RtlGetVersion"); + osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); + if (!getversion || getversion(&osInfo)) { + GetVersionExW(&osInfo); + } + osInfoInitialized = 1; + } + GetSystemInfo(&sys.info); + + /* + * Define the tcl_platform array. + */ + + Tcl_SetVar2(interp, "tcl_platform", "platform", "windows", + TCL_GLOBAL_ONLY); + if (osInfo.dwPlatformId < NUMPLATFORMS) { + Tcl_SetVar2(interp, "tcl_platform", "os", + platforms[osInfo.dwPlatformId], TCL_GLOBAL_ONLY); + } + wsprintfA(buffer, "%d.%d", osInfo.dwMajorVersion, osInfo.dwMinorVersion); + Tcl_SetVar2(interp, "tcl_platform", "osVersion", buffer, TCL_GLOBAL_ONLY); + if (sys.oemId.wProcessorArchitecture < NUMPROCESSORS) { + Tcl_SetVar2(interp, "tcl_platform", "machine", + processors[sys.oemId.wProcessorArchitecture], + TCL_GLOBAL_ONLY); + } + +#ifdef _DEBUG + /* + * The existence of the "debug" element of the tcl_platform array + * indicates that this particular Tcl shell has been compiled with debug + * information. Using "info exists tcl_platform(debug)" a Tcl script can + * direct the interpreter to load debug versions of DLLs with the load + * command. + */ + + Tcl_SetVar2(interp, "tcl_platform", "debug", "1", + TCL_GLOBAL_ONLY); +#endif + + /* + * Set up the HOME environment variable from the HOMEDRIVE & HOMEPATH + * environment variables, if necessary. + */ + + Tcl_DStringInit(&ds); + ptr = Tcl_GetVar2(interp, "env", "HOME", TCL_GLOBAL_ONLY); + if (ptr == NULL) { + ptr = Tcl_GetVar2(interp, "env", "HOMEDRIVE", TCL_GLOBAL_ONLY); + if (ptr != NULL) { + Tcl_DStringAppend(&ds, ptr, -1); + } + ptr = Tcl_GetVar2(interp, "env", "HOMEPATH", TCL_GLOBAL_ONLY); + if (ptr != NULL) { + Tcl_DStringAppend(&ds, ptr, -1); + } + if (Tcl_DStringLength(&ds) > 0) { + Tcl_SetVar2(interp, "env", "HOME", Tcl_DStringValue(&ds), + TCL_GLOBAL_ONLY); + } else { + Tcl_SetVar2(interp, "env", "HOME", "c:\\", TCL_GLOBAL_ONLY); + } + } + + /* + * Initialize the user name from the environment first, since this is much + * faster than asking the system. + * Note: cchUserNameLen is number of characters including nul terminator. + */ + + Tcl_DStringInit(&ds); + if (TclGetEnv("USERNAME", &ds) == NULL) { + if (GetUserName(szUserName, &cchUserNameLen) != 0) { + int cbUserNameLen = cchUserNameLen - 1; + cbUserNameLen *= sizeof(TCHAR); + Tcl_WinTCharToUtf(szUserName, cbUserNameLen, &ds); + } + } + Tcl_SetVar2(interp, "tcl_platform", "user", Tcl_DStringValue(&ds), + TCL_GLOBAL_ONLY); + Tcl_DStringFree(&ds); + + /* + * Define what the platform PATH separator is. [TIP #315] + */ + + Tcl_SetVar2(interp, "tcl_platform","pathSeparator", ";", TCL_GLOBAL_ONLY); +} + +/* + *---------------------------------------------------------------------- + * + * TclpFindVariable -- + * + * Locate the entry in environ for a given name. On Unix this routine is + * case sensitive, on Windows this matches mioxed case. + * + * Results: + * The return value is the index in environ of an entry with the name + * "name", or -1 if there is no such entry. The integer at *lengthPtr is + * filled in with the length of name (if a matching entry is found) or + * the length of the environ array (if no matching entry is found). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclpFindVariable( + 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 + * entries in environ (for unsuccessful + * searches). */ +{ + int i, length, result = -1; + register const char *env, *p1, *p2; + char *envUpper, *nameUpper; + Tcl_DString envString; + + /* + * Convert the name to all upper case for the case insensitive comparison. + */ + + length = strlen(name); + nameUpper = ckalloc(length + 1); + memcpy(nameUpper, name, (size_t) length+1); + Tcl_UtfToUpper(nameUpper); + + Tcl_DStringInit(&envString); + for (i = 0, env = environ[i]; env != NULL; i++, env = environ[i]) { + /* + * Chop the env string off after the equal sign, then Convert the name + * to all upper case, so we do not have to convert all the characters + * after the equal sign. + */ + + envUpper = Tcl_ExternalToUtfDString(NULL, env, -1, &envString); + p1 = strchr(envUpper, '='); + if (p1 == NULL) { + continue; + } + length = (int) (p1 - envUpper); + Tcl_DStringSetLength(&envString, length+1); + Tcl_UtfToUpper(envUpper); + + p1 = envUpper; + p2 = nameUpper; + for (; *p2 == *p1; p1++, p2++) { + /* NULL loop body. */ + } + if ((*p1 == '=') && (*p2 == '\0')) { + *lengthPtr = length; + result = i; + goto done; + } + + Tcl_DStringFree(&envString); + } + + *lengthPtr = i; + + done: + Tcl_DStringFree(&envString); + ckfree(nameUpper); + return result; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/win/tclWinInt.h b/win/tclWinInt.h new file mode 100644 index 0000000..43799d0 --- /dev/null +++ b/win/tclWinInt.h @@ -0,0 +1,164 @@ +/* + * tclWinInt.h -- + * + * Declarations of Windows-specific shared variables and procedures. + * + * Copyright (c) 1994-1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#ifndef _TCLWININT +#define _TCLWININT + +#include "tclInt.h" + +#ifdef HAVE_NO_SEH +/* + * Unlike Borland and Microsoft, we don't register exception handlers by + * pushing registration records onto the runtime stack. Instead, we register + * them by creating an TCLEXCEPTION_REGISTRATION within the activation record. + */ + +typedef struct TCLEXCEPTION_REGISTRATION { + struct TCLEXCEPTION_REGISTRATION *link; + EXCEPTION_DISPOSITION (*handler)( + struct _EXCEPTION_RECORD*, void*, struct _CONTEXT*, void*); + void *ebp; + void *esp; + int status; +} TCLEXCEPTION_REGISTRATION; +#endif + +/* + * Windows version dependend functions + */ +typedef struct TclWinProcs { + BOOL (WINAPI *cancelSynchronousIo)(HANDLE); +} TclWinProcs; + +MODULE_SCOPE TclWinProcs tclWinProcs; + +/* + * Some versions of Borland C have a define for the OSVERSIONINFO for + * Win32s and for NT, but not for Windows 95. + * Define VER_PLATFORM_WIN32_CE for those without newer headers. + */ + +#ifndef VER_PLATFORM_WIN32_WINDOWS +#define VER_PLATFORM_WIN32_WINDOWS 1 +#endif +#ifndef VER_PLATFORM_WIN32_CE +#define VER_PLATFORM_WIN32_CE 3 +#endif + +#ifdef _WIN64 +# define TCL_I_MODIFIER "I" +#else +# define TCL_I_MODIFIER "" +#endif + +/* + * Declarations of functions that are not accessible by way of the + * stubs table. + */ + +MODULE_SCOPE char TclWinDriveLetterForVolMountPoint( + const TCHAR *mountPoint); +MODULE_SCOPE void TclWinEncodingsCleanup(); +MODULE_SCOPE void TclWinInit(HINSTANCE hInst); +MODULE_SCOPE TclFile TclWinMakeFile(HANDLE handle); +MODULE_SCOPE Tcl_Channel TclWinOpenConsoleChannel(HANDLE handle, + char *channelName, int permissions); +MODULE_SCOPE Tcl_Channel TclWinOpenFileChannel(HANDLE handle, char *channelName, + int permissions, int appendMode); +MODULE_SCOPE Tcl_Channel TclWinOpenSerialChannel(HANDLE handle, + char *channelName, int permissions); +MODULE_SCOPE HANDLE TclWinSerialOpen(HANDLE handle, const TCHAR *name, + DWORD access); +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 *); +MODULE_SCOPE Tcl_Mutex *TclpNewAllocMutex(void); +MODULE_SCOPE void * TclpGetAllocCache(void); +MODULE_SCOPE void TclpSetAllocCache(void *); +#endif /* TCL_THREADS */ + +/* Needed by tclWinFile.c and tclWinFCmd.c */ +#ifndef FILE_ATTRIBUTE_REPARSE_POINT +#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 new file mode 100644 index 0000000..3ad6328 --- /dev/null +++ b/win/tclWinLoad.c @@ -0,0 +1,426 @@ +/* + * tclWinLoad.c -- + * + * This function provides a version of the TclLoadFile that works with + * the Windows "LoadLibrary" and "GetProcAddress" API for dynamic + * loading. + * + * Copyright (c) 1995-1997 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#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); + +/* + *---------------------------------------------------------------------- + * + * TclpDlopen -- + * + * Dynamically loads a binary code file into memory and returns a handle + * to the new code. + * + * Results: + * A standard Tcl completion code. If an error occurs, an error message + * is left in the interp's result. + * + * Side effects: + * New code suddenly appears in memory. + * + *---------------------------------------------------------------------- + */ + +int +TclpDlopen( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Obj *pathPtr, /* Name of the file containing the desired + * code (UTF-8). */ + Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded + * file which will be passed back to + * (*unloadProcPtr)() to unload the file. */ + Tcl_FSUnloadFileProc **unloadProcPtr, + /* Filled with address of Tcl_FSUnloadFileProc + * function which should be used for this + * file. */ + int flags) +{ + HINSTANCE hInstance; + const TCHAR *nativeName; + Tcl_LoadHandle handlePtr; + DWORD firstError; + + /* + * First try the full path the user gave us. This is particularly + * important if the cwd is inside a vfs, and we are trying to load using a + * relative path. + */ + + nativeName = Tcl_FSGetNativePath(pathPtr); + 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 + * binary path. + */ + + Tcl_DString ds; + + /* + * Remember the first error on load attempt to be used if the + * second load attempt below also fails. + */ + firstError = GetLastError(); + + nativeName = Tcl_WinUtfToTChar(Tcl_GetString(pathPtr), -1, &ds); + hInstance = LoadLibraryEx(nativeName, NULL, + LOAD_WITH_ALTERED_SEARCH_PATH); + Tcl_DStringFree(&ds); + } + + if (hInstance == NULL) { + DWORD lastError; + Tcl_Obj *errMsg; + + /* + * 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; + + errMsg = Tcl_ObjPrintf("couldn't load library \"%s\": ", + Tcl_GetString(pathPtr)); + + /* + * Check for possible DLL errors. This doesn't work quite right, + * because Windows seems to only return ERROR_MOD_NOT_FOUND for just + * about any problem, but it's better than nothing. It'd be even + * better if there was a way to get what DLLs + */ + + if (interp) { + switch (lastError) { + case ERROR_MOD_NOT_FOUND: + Tcl_SetErrorCode(interp, "WIN_LOAD", "MOD_NOT_FOUND", NULL); + goto notFoundMsg; + case ERROR_DLL_NOT_FOUND: + Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_NOT_FOUND", NULL); + notFoundMsg: + Tcl_AppendToObj(errMsg, "this library or a dependent library" + " could not be found in library path", -1); + break; + case ERROR_PROC_NOT_FOUND: + Tcl_SetErrorCode(interp, "WIN_LOAD", "PROC_NOT_FOUND", NULL); + Tcl_AppendToObj(errMsg, "A function specified in the import" + " table could not be resolved by the system. Windows" + " is not telling which one, I'm sorry.", -1); + break; + case ERROR_INVALID_DLL: + Tcl_SetErrorCode(interp, "WIN_LOAD", "INVALID_DLL", NULL); + Tcl_AppendToObj(errMsg, "this library or a dependent library" + " is damaged", -1); + break; + case ERROR_DLL_INIT_FAILED: + Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_INIT_FAILED", NULL); + Tcl_AppendToObj(errMsg, "the library initialization" + " routine failed", -1); + break; + 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; + } + + /* + * Succeded; package everything up for Tcl. + */ + + handlePtr = ckalloc(sizeof(struct Tcl_LoadHandle_)); + handlePtr->clientData = (ClientData) hInstance; + handlePtr->findSymbolProcPtr = &FindSymbol; + handlePtr->unloadFileProcPtr = &UnloadFile; + *loadHandle = handlePtr; + *unloadProcPtr = &UnloadFile; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * FindSymbol -- + * + * Looks up a symbol, by name, through a handle associated with a + * previously loaded piece of code (shared library). + * + * Results: + * Returns a pointer to the function associated with 'symbol' if it is + * found. Otherwise returns NULL and may leave an error message in the + * interp's result. + * + *---------------------------------------------------------------------- + */ + +static void * +FindSymbol( + Tcl_Interp *interp, + Tcl_LoadHandle loadHandle, + const char *symbol) +{ + HINSTANCE hInstance = (HINSTANCE) loadHandle->clientData; + Tcl_PackageInitProc *proc = NULL; + + /* + * For each symbol, check for both Symbol and _Symbol, since Borland + * generates C symbols with a leading '_' by default. + */ + + proc = (void *) GetProcAddress(hInstance, symbol); + if (proc == NULL) { + Tcl_DString ds; + const char *sym2; + + Tcl_DStringInit(&ds); + TclDStringAppendLiteral(&ds, "_"); + sym2 = Tcl_DStringAppend(&ds, symbol, -1); + proc = (Tcl_PackageInitProc *) GetProcAddress(hInstance, sym2); + Tcl_DStringFree(&ds); + } + if (proc == NULL && interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot find symbol \"%s\"", symbol)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL); + } + return proc; +} + +/* + *---------------------------------------------------------------------- + * + * UnloadFile -- + * + * Unloads a dynamically loaded binary code file from memory. Code + * pointers in the formerly loaded file are no longer valid after calling + * this function. + * + * Results: + * None. + * + * Side effects: + * Code removed from memory. + * + *---------------------------------------------------------------------- + */ + +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 hInstance = (HINSTANCE) loadHandle->clientData; + + FreeLibrary(hInstance); + ckfree(loadHandle); +} + +/* + *---------------------------------------------------------------------- + * + * TclGuessPackageName -- + * + * If the "load" command is invoked without providing a package name, + * this function is invoked to try to figure it out. + * + * Results: + * Always returns 0 to indicate that we couldn't figure out a package + * name; generic code will then try to guess the package from the file + * name. A return value of 1 would have meant that we figured out the + * package name and put it in bufPtr. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclGuessPackageName( + 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. */ +{ + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * 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 + * fill-column: 78 + * End: + */ diff --git a/win/tclWinNotify.c b/win/tclWinNotify.c new file mode 100644 index 0000000..28c8445 --- /dev/null +++ b/win/tclWinNotify.c @@ -0,0 +1,618 @@ +/* + * tclWinNotify.c -- + * + * This file contains Windows-specific procedures for the notifier, which + * is the lowest-level part of the Tcl event loop. This file works + * together with ../generic/tclNotify.c. + * + * Copyright (c) 1995-1997 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tclInt.h" + +/* + * The follwing static indicates whether this module has been initialized. + */ + +#define INTERVAL_TIMER 1 /* Handle of interval timer. */ + +#define WM_WAKEUP WM_USER /* Message that is send by + * Tcl_AlertNotifier. */ +/* + * The following static structure contains the state information for the + * Windows implementation of the Tcl notifier. One of these structures is + * created for each thread that is using the notifier. + */ + +typedef struct { + CRITICAL_SECTION crit; /* Monitor for this notifier. */ + DWORD thread; /* Identifier for thread associated with this + * notifier. */ + HANDLE event; /* Event object used to wake up the notifier + * thread. */ + int pending; /* Alert message pending, this field is locked + * by the notifierMutex. */ + HWND hwnd; /* Messaging window. */ + int timeout; /* Current timeout value. */ + int timerActive; /* 1 if interval timer is running. */ +} ThreadSpecificData; + +static Tcl_ThreadDataKey dataKey; + +/* + * The following static indicates the number of threads that have initialized + * notifiers. It controls the lifetime of the TclNotifier window class. + * + * You must hold the notifierMutex lock before accessing this variable. + */ + +static int notifierCount = 0; +static const TCHAR className[] = TEXT("TclNotifier"); +static int initialized = 0; +static CRITICAL_SECTION notifierMutex; + +/* + * Static routines defined in this file. + */ + +static LRESULT CALLBACK NotifierProc(HWND hwnd, UINT message, + WPARAM wParam, LPARAM lParam); + +/* + *---------------------------------------------------------------------- + * + * Tcl_InitNotifier -- + * + * Initializes the platform specific notifier state. + * + * Results: + * Returns a handle to the notifier state for this thread.. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +ClientData +Tcl_InitNotifier(void) +{ + if (tclNotifierHooks.initNotifierProc) { + return tclNotifierHooks.initNotifierProc(); + } else { + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + WNDCLASS class; + + TclpMasterLock(); + if (!initialized) { + initialized = 1; + InitializeCriticalSection(¬ifierMutex); + } + TclpMasterUnlock(); + + /* + * Register Notifier window class if this is the first thread to use + * this module. + */ + + EnterCriticalSection(¬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++; + LeaveCriticalSection(¬ifierMutex); + + tsdPtr->pending = 0; + tsdPtr->timerActive = 0; + + InitializeCriticalSection(&tsdPtr->crit); + + tsdPtr->hwnd = NULL; + tsdPtr->thread = GetCurrentThreadId(); + tsdPtr->event = CreateEvent(NULL, TRUE /* manual */, + FALSE /* !signaled */, NULL); + + return tsdPtr; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FinalizeNotifier -- + * + * This function is called to cleanup the notifier state before a thread + * is terminated. + * + * Results: + * None. + * + * Side effects: + * May dispose of the notifier window and class. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_FinalizeNotifier( + ClientData clientData) /* Pointer to notifier data. */ +{ + 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. + */ + + if (tsdPtr == NULL) { + return; + } + + DeleteCriticalSection(&tsdPtr->crit); + CloseHandle(tsdPtr->event); + + /* + * Clean up the timer and messaging window for this thread. + */ + + 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. + */ + + EnterCriticalSection(¬ifierMutex); + if (notifierCount) { + notifierCount--; + if (notifierCount == 0) { + UnregisterClass(className, TclWinGetTclInstance()); + } + } + LeaveCriticalSection(¬ifierMutex); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AlertNotifier -- + * + * Wake up the specified notifier from any thread. This routine is called + * by the platform independent notifier code whenever the Tcl_ThreadAlert + * routine is called. This routine is guaranteed not to be called on a + * given notifier after Tcl_FinalizeNotifier is called for that notifier. + * This routine is typically called from a thread other than the + * notifier's thread. + * + * Results: + * None. + * + * Side effects: + * Sends a message to the messaging window for the notifier if there + * isn't already one pending. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AlertNotifier( + ClientData clientData) /* Pointer to thread data. */ +{ + if (tclNotifierHooks.alertNotifierProc) { + tclNotifierHooks.alertNotifierProc(clientData); + return; + } else { + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData; + + /* + * Note that we do not need to lock around access to the hwnd because + * the race condition has no effect since any race condition implies + * that the notifier thread is already awake. + */ + + if (tsdPtr->hwnd) { + /* + * 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); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetTimer -- + * + * This procedure sets the current notifier timer value. The notifier + * will ensure that Tcl_ServiceAll() is called after the specified + * interval, even if no events have occurred. + * + * Results: + * None. + * + * Side effects: + * Replaces any previous timer. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetTimer( + const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ +{ + if (tclNotifierHooks.setTimerProc) { + tclNotifierHooks.setTimerProc(timePtr); + return; + } else { + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + UINT timeout; + + /* + * We only need to set up an interval timer if we're being called from + * an external event loop. If we don't have a window handle then we + * just return immediately and let Tcl_WaitForEvent handle timeouts. + */ + + 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); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ServiceModeHook -- + * + * This function is invoked whenever the service mode changes. + * + * Results: + * None. + * + * Side effects: + * If this is the first time the notifier is set into TCL_SERVICE_ALL, + * then the communication window is created. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_ServiceModeHook( + int mode) /* Either TCL_SERVICE_ALL, or + * TCL_SERVICE_NONE. */ +{ + if (tclNotifierHooks.serviceModeHookProc) { + tclNotifierHooks.serviceModeHookProc(mode); + return; + } else { + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + /* + * If this is the first time that the notifier has been used from a + * modal loop, then create a communication window. Note that after this + * point, the application needs to service events in a timely fashion + * or Windows will hang waiting for the window to respond to + * synchronous system messages. At some point, we may want to consider + * destroying the window if we leave the modal loop, but for now we'll + * leave it around. + */ + + if (mode == TCL_SERVICE_ALL && !tsdPtr->hwnd) { + tsdPtr->hwnd = CreateWindow(className, className, + WS_TILED, 0, 0, 0, 0, NULL, NULL, TclWinGetTclInstance(), + NULL); + + /* + * 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); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * NotifierProc -- + * + * This procedure is invoked by Windows to process events on the notifier + * window. Messages will be sent to this window in response to external + * timer events or calls to TclpAlertTsdPtr-> + * + * Results: + * A standard windows result. + * + * Side effects: + * Services any pending events. + * + *---------------------------------------------------------------------- + */ + +static LRESULT CALLBACK +NotifierProc( + HWND hwnd, /* Passed on... */ + UINT message, /* What messsage is this? */ + WPARAM wParam, /* Passed on... */ + LPARAM lParam) /* Passed on... */ +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if (message == WM_WAKEUP) { + EnterCriticalSection(&tsdPtr->crit); + tsdPtr->pending = 0; + LeaveCriticalSection(&tsdPtr->crit); + } else if (message != WM_TIMER) { + return DefWindowProc(hwnd, message, wParam, lParam); + } + + /* + * Process all of the runnable events. + */ + + Tcl_ServiceAll(); + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_WaitForEvent -- + * + * This function is called by Tcl_DoOneEvent to wait for new events on + * the message queue. If the block time is 0, then Tcl_WaitForEvent just + * polls the event queue without blocking. + * + * Results: + * Returns -1 if a WM_QUIT message is detected, returns 1 if a message + * was dispatched, otherwise returns 0. + * + * Side effects: + * Dispatches a message to a window procedure, which could do anything. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_WaitForEvent( + const Tcl_Time *timePtr) /* Maximum block time, or NULL. */ +{ + if (tclNotifierHooks.waitForEventProc) { + return tclNotifierHooks.waitForEventProc(timePtr); + } else { + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + MSG msg; + DWORD timeout, result; + int status; + + /* + * Compute the timeout in milliseconds. + */ + + if (timePtr) { + /* + * TIP #233 (Virtualized Time). Convert virtual domain delay to + * real-time. + */ + + Tcl_Time myTime; + + myTime.sec = timePtr->sec; + myTime.usec = timePtr->usec; + + if (myTime.sec != 0 || myTime.usec != 0) { + tclScaleTimeProcPtr(&myTime, tclTimeClientData); + } + + timeout = myTime.sec * 1000 + myTime.usec / 1000; + } else { + timeout = INFINITE; + } + + /* + * Check to see if there are any messages in the queue before waiting + * because MsgWaitForMultipleObjects will not wake up if there are + * events currently sitting in the queue. + */ + + if (!PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE)) { + /* + * Wait for something to happen (a signal from another thread, a + * message, or timeout) or loop servicing asynchronous procedure + * calls queued to this thread. + */ + + again: + result = MsgWaitForMultipleObjectsEx(1, &tsdPtr->event, timeout, + QS_ALLINPUT, MWMO_ALERTABLE); + if (result == WAIT_IO_COMPLETION) { + goto again; + } else if (result == WAIT_FAILED) { + status = -1; + goto end; + } + } + + /* + * Check to see if there are any messages to process. + */ + + if (PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE)) { + /* + * Retrieve and dispatch the first message. + */ + + 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 { + status = 0; + } + + end: + ResetEvent(tsdPtr->event); + return status; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Sleep -- + * + * Delay execution for the specified number of milliseconds. + * + * Results: + * None. + * + * Side effects: + * Time passes. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_Sleep( + int ms) /* Number of milliseconds to sleep. */ +{ + /* + * Simply calling 'Sleep' for the requisite number of milliseconds can + * make the process appear to wake up early because it isn't synchronized + * with the CPU performance counter that is used in tclWinTime.c. This + * behavior is probably benign, but messes up some of the corner cases in + * the test suite. We get around this problem by repeating the 'Sleep' + * call as many times as necessary to make the clock advance by the + * requisite amount. + */ + + Tcl_Time now; /* Current wall clock time. */ + Tcl_Time desired; /* Desired wakeup time. */ + Tcl_Time vdelay; /* Time to sleep, for scaling virtual -> + * real. */ + DWORD sleepTime; /* Time to sleep, real-time */ + + vdelay.sec = ms / 1000; + vdelay.usec = (ms % 1000) * 1000; + + Tcl_GetTime(&now); + desired.sec = now.sec + vdelay.sec; + desired.usec = now.usec + vdelay.usec; + if (desired.usec > 1000000) { + ++desired.sec; + desired.usec -= 1000000; + } + + /* + * TIP #233: Scale delay from virtual to real-time. + */ + + tclScaleTimeProcPtr(&vdelay, tclTimeClientData); + sleepTime = vdelay.sec * 1000 + vdelay.usec / 1000; + + for (;;) { + SleepEx(sleepTime, TRUE); + Tcl_GetTime(&now); + if (now.sec > desired.sec) { + break; + } else if ((now.sec == desired.sec) && (now.usec >= desired.usec)) { + break; + } + + vdelay.sec = desired.sec - now.sec; + vdelay.usec = desired.usec - now.usec; + + tclScaleTimeProcPtr(&vdelay, tclTimeClientData); + sleepTime = vdelay.sec * 1000 + vdelay.usec / 1000; + } +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c new file mode 100644 index 0000000..5f1aa70 --- /dev/null +++ b/win/tclWinPipe.c @@ -0,0 +1,3459 @@ +/* + * tclWinPipe.c -- + * + * This file implements the Windows-specific exec pipeline functions, the + * "pipe" channel driver, and the "pid" Tcl command. + * + * Copyright (c) 1996-1997 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. + */ + +#include "tclWinInt.h" + +/* + * The following variable is used to tell whether this module has been + * initialized. + */ + +static int initialized = 0; + +/* + * The pipeMutex locks around access to the initialized and procList + * variables, and it is used to protect background threads from being + * terminated while they are using APIs that hold locks. + */ + +TCL_DECLARE_MUTEX(pipeMutex) + +/* + * The following defines identify the various types of applications that run + * under windows. There is special case code for the various types. + */ + +#define APPL_NONE 0 +#define APPL_DOS 1 +#define APPL_WIN3X 2 +#define APPL_WIN32 3 + +/* + * The following constants and structures are used to encapsulate the state of + * various types of files used in a pipeline. This used to have a 1 && 2 that + * supported Win32s. + */ + +#define WIN_FILE 3 /* Basic Win32 file. */ + +/* + * This structure encapsulates the common state associated with all file types + * used in a pipeline. + */ + +typedef struct { + int type; /* One of the file types defined above. */ + HANDLE handle; /* Open file handle. */ +} WinFile; + +/* + * This list is used to map from pids to process handles. + */ + +typedef struct ProcInfo { + HANDLE hProcess; + DWORD dwProcessId; + struct ProcInfo *nextPtr; +} ProcInfo; + +static ProcInfo *procList; + +/* + * Bit masks used in the flags field of the PipeInfo structure below. + */ + +#define PIPE_PENDING (1<<0) /* Message is pending in the queue. */ +#define PIPE_ASYNC (1<<1) /* Channel is non-blocking. */ + +/* + * Bit masks used in the sharedFlags field of the PipeInfo structure below. + */ + +#define PIPE_EOF (1<<2) /* Pipe has reached EOF. */ +#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. + */ + +typedef struct PipeInfo { + struct PipeInfo *nextPtr; /* Pointer to next registered pipe. */ + Tcl_Channel channel; /* Pointer to channel structure. */ + int validMask; /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, or TCL_EXCEPTION: indicates + * which operations are valid on the file. */ + int watchMask; /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, or TCL_EXCEPTION: indicates + * which events should be reported. */ + int flags; /* State flags, see above for a list. */ + TclFile readFile; /* Output from pipe. */ + TclFile writeFile; /* Input from pipe. */ + TclFile errorFile; /* Error output from pipe. */ + int numPids; /* Number of processes attached to pipe. */ + Tcl_Pid *pidPtr; /* Pids of attached processes. */ + 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. */ + 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 + * writer thread so access must be + * synchronized with the writable object. + */ + char *writeBuf; /* Current background output buffer. Access is + * synchronized with the writable object. */ + int writeBufLen; /* Size of write buffer. Access is + * synchronized with the writable object. */ + int toWrite; /* Current amount to be written. Access is + * synchronized with the writable object. */ + int readFlags; /* Flags that are shared with the reader + * thread. Access is synchronized with the + * readable object. */ + char extraByte; /* Buffer for extra character consumed by + * reader thread. This byte is shared with the + * reader thread so access must be + * synchronized with the readable object. */ +} PipeInfo; + +typedef struct { + /* + * The following pointer refers to the head of the list of pipes that are + * being watched for file events. + */ + + PipeInfo *firstPipePtr; +} ThreadSpecificData; + +static Tcl_ThreadDataKey dataKey; + +/* + * The following structure is what is added to the Tcl event queue when pipe + * events are generated. + */ + +typedef struct { + Tcl_Event header; /* Information that is standard for all + * events. */ + PipeInfo *infoPtr; /* Pointer to pipe info structure. Note that + * we still have to verify that the pipe + * exists before dereferencing this + * pointer. */ +} PipeEvent; + +/* + * Declarations for functions used only in this file. + */ + +static int ApplicationType(Tcl_Interp *interp, + const char *fileName, char *fullName); +static void BuildCommandLine(const char *executable, int argc, + const char **argv, Tcl_DString *linePtr); +static BOOL HasConsole(void); +static int PipeBlockModeProc(ClientData instanceData, int mode); +static void PipeCheckProc(ClientData clientData, int flags); +static int PipeClose2Proc(ClientData instanceData, + Tcl_Interp *interp, int flags); +static int PipeEventProc(Tcl_Event *evPtr, int flags); +static int PipeGetHandleProc(ClientData instanceData, + int direction, ClientData *handlePtr); +static void PipeInit(void); +static int PipeInputProc(ClientData instanceData, char *buf, + int toRead, int *errorCode); +static int PipeOutputProc(ClientData instanceData, + const char *buf, int toWrite, int *errorCode); +static DWORD WINAPI PipeReaderThread(LPVOID arg); +static void PipeSetupProc(ClientData clientData, int flags); +static void PipeWatchProc(ClientData instanceData, int mask); +static DWORD WINAPI PipeWriterThread(LPVOID arg); +static int TempFileName(TCHAR name[MAX_PATH]); +static int WaitForRead(PipeInfo *infoPtr, int blocking); +static void PipeThreadActionProc(ClientData instanceData, + int action); + +/* + * This structure describes the channel type structure for command pipe based + * I/O. + */ + +static const Tcl_ChannelType pipeChannelType = { + "pipe", /* Type name. */ + TCL_CHANNEL_VERSION_5, /* v5 channel */ + TCL_CLOSE2PROC, /* Close proc. */ + PipeInputProc, /* Input proc. */ + PipeOutputProc, /* Output proc. */ + NULL, /* Seek proc. */ + NULL, /* Set option proc. */ + NULL, /* Get option proc. */ + PipeWatchProc, /* Set up notifier to watch the channel. */ + PipeGetHandleProc, /* Get an OS handle from channel. */ + PipeClose2Proc, /* close2proc */ + PipeBlockModeProc, /* Set blocking or non-blocking mode.*/ + NULL, /* flush proc. */ + NULL, /* handler proc. */ + NULL, /* wide seek proc */ + PipeThreadActionProc, /* thread action proc */ + NULL /* truncate */ +}; + +/* + *---------------------------------------------------------------------- + * + * PipeInit -- + * + * This function initializes the static variables for this file. + * + * Results: + * None. + * + * Side effects: + * Creates a new event source. + * + *---------------------------------------------------------------------- + */ + +static void +PipeInit(void) +{ + ThreadSpecificData *tsdPtr; + + /* + * Check the initialized flag first, then check again in the mutex. This + * is a speed enhancement. + */ + + if (!initialized) { + Tcl_MutexLock(&pipeMutex); + if (!initialized) { + initialized = 1; + procList = NULL; + } + Tcl_MutexUnlock(&pipeMutex); + } + + tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); + if (tsdPtr == NULL) { + tsdPtr = TCL_TSD_INIT(&dataKey); + tsdPtr->firstPipePtr = NULL; + Tcl_CreateEventSource(PipeSetupProc, PipeCheckProc, NULL); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclpFinalizePipes -- + * + * This function is called from Tcl_FinalizeThread to finalize the + * platform specific pipe subsystem. + * + * Results: + * None. + * + * Side effects: + * Removes the pipe event source. + * + *---------------------------------------------------------------------- + */ + +void +TclpFinalizePipes(void) +{ + ThreadSpecificData *tsdPtr; + + tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); + if (tsdPtr != NULL) { + Tcl_DeleteEventSource(PipeSetupProc, PipeCheckProc, NULL); + } +} + +/* + *---------------------------------------------------------------------- + * + * PipeSetupProc -- + * + * This function is invoked before Tcl_DoOneEvent blocks waiting for an + * event. + * + * Results: + * None. + * + * Side effects: + * Adjusts the block time if needed. + * + *---------------------------------------------------------------------- + */ + +void +PipeSetupProc( + ClientData data, /* Not used. */ + int flags) /* Event flags as passed to Tcl_DoOneEvent. */ +{ + PipeInfo *infoPtr; + Tcl_Time blockTime = { 0, 0 }; + int block = 1; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if (!(flags & TCL_FILE_EVENTS)) { + return; + } + + /* + * Look to see if any events are already pending. If they are, poll. + */ + + for (infoPtr = tsdPtr->firstPipePtr; infoPtr != NULL; + infoPtr = infoPtr->nextPtr) { + if (infoPtr->watchMask & TCL_WRITABLE) { + if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) { + block = 0; + } + } + if (infoPtr->watchMask & TCL_READABLE) { + if (WaitForRead(infoPtr, 0) >= 0) { + block = 0; + } + } + } + if (!block) { + Tcl_SetMaxBlockTime(&blockTime); + } +} + +/* + *---------------------------------------------------------------------- + * + * PipeCheckProc -- + * + * This function is called by Tcl_DoOneEvent to check the pipe event + * source for events. + * + * Results: + * None. + * + * Side effects: + * May queue an event. + * + *---------------------------------------------------------------------- + */ + +static void +PipeCheckProc( + ClientData data, /* Not used. */ + int flags) /* Event flags as passed to Tcl_DoOneEvent. */ +{ + PipeInfo *infoPtr; + PipeEvent *evPtr; + int needEvent; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if (!(flags & TCL_FILE_EVENTS)) { + return; + } + + /* + * Queue events for any ready pipes that don't already have events queued. + */ + + for (infoPtr = tsdPtr->firstPipePtr; infoPtr != NULL; + infoPtr = infoPtr->nextPtr) { + if (infoPtr->flags & PIPE_PENDING) { + continue; + } + + /* + * Queue an event if the pipe is signaled for reading or writing. + */ + + needEvent = 0; + if ((infoPtr->watchMask & TCL_WRITABLE) && + (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT)) { + needEvent = 1; + } + + if ((infoPtr->watchMask & TCL_READABLE) && + (WaitForRead(infoPtr, 0) >= 0)) { + needEvent = 1; + } + + if (needEvent) { + infoPtr->flags |= PIPE_PENDING; + evPtr = ckalloc(sizeof(PipeEvent)); + evPtr->header.proc = PipeEventProc; + evPtr->infoPtr = infoPtr; + Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * TclWinMakeFile -- + * + * This function constructs a new TclFile from a given data and type + * value. + * + * Results: + * Returns a newly allocated WinFile as a TclFile. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +TclFile +TclWinMakeFile( + HANDLE handle) /* Type-specific data. */ +{ + WinFile *filePtr; + + filePtr = ckalloc(sizeof(WinFile)); + filePtr->type = WIN_FILE; + filePtr->handle = handle; + + return (TclFile)filePtr; +} + +/* + *---------------------------------------------------------------------- + * + * TempFileName -- + * + * Gets a temporary file name and deals with the fact that the temporary + * file path provided by Windows may not actually exist if the TMP or + * TEMP environment variables refer to a non-existent directory. + * + * Results: + * 0 if error, non-zero otherwise. If non-zero is returned, the name + * buffer will be filled with a name that can be used to construct a + * temporary file. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TempFileName( + TCHAR name[MAX_PATH]) /* Buffer in which name for temporary file + * gets stored. */ +{ + const TCHAR *prefix = TEXT("TCL"); + if (GetTempPath(MAX_PATH, name) != 0) { + if (GetTempFileName(name, prefix, 0, name) != 0) { + return 1; + } + } + name[0] = '.'; + name[1] = '\0'; + return GetTempFileName(name, prefix, 0, name); +} + +/* + *---------------------------------------------------------------------- + * + * TclpMakeFile -- + * + * Make a TclFile from a channel. + * + * Results: + * Returns a new TclFile or NULL on failure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +TclFile +TclpMakeFile( + Tcl_Channel channel, /* Channel to get file from. */ + int direction) /* Either TCL_READABLE or TCL_WRITABLE. */ +{ + HANDLE handle; + + if (Tcl_GetChannelHandle(channel, direction, + (ClientData *) &handle) == TCL_OK) { + return TclWinMakeFile(handle); + } else { + return (TclFile) NULL; + } +} + +/* + *---------------------------------------------------------------------- + * + * TclpOpenFile -- + * + * This function opens files for use in a pipeline. + * + * Results: + * Returns a newly allocated TclFile structure containing the file + * handle. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +TclFile +TclpOpenFile( + const char *path, /* The name of the file to open. */ + int mode) /* In what mode to open the file? */ +{ + HANDLE handle; + DWORD accessMode, createMode, shareMode, flags; + Tcl_DString ds; + const TCHAR *nativePath; + + /* + * Map the access bits to the NT access mode. + */ + + switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) { + case O_RDONLY: + accessMode = GENERIC_READ; + break; + case O_WRONLY: + accessMode = GENERIC_WRITE; + break; + case O_RDWR: + accessMode = (GENERIC_READ | GENERIC_WRITE); + break; + default: + TclWinConvertError(ERROR_INVALID_FUNCTION); + return NULL; + } + + /* + * Map the creation flags to the NT create mode. + */ + + switch (mode & (O_CREAT | O_EXCL | O_TRUNC)) { + case (O_CREAT | O_EXCL): + case (O_CREAT | O_EXCL | O_TRUNC): + createMode = CREATE_NEW; + break; + case (O_CREAT | O_TRUNC): + createMode = CREATE_ALWAYS; + break; + case O_CREAT: + createMode = OPEN_ALWAYS; + break; + case O_TRUNC: + case (O_TRUNC | O_EXCL): + createMode = TRUNCATE_EXISTING; + break; + default: + createMode = OPEN_EXISTING; + break; + } + + nativePath = Tcl_WinUtfToTChar(path, -1, &ds); + + /* + * If the file is not being created, use the existing file attributes. + */ + + flags = 0; + if (!(mode & O_CREAT)) { + flags = GetFileAttributes(nativePath); + if (flags == 0xFFFFFFFF) { + flags = 0; + } + } + + /* + * Set up the file sharing mode. We want to allow simultaneous access. + */ + + shareMode = FILE_SHARE_READ | FILE_SHARE_WRITE; + + /* + * Now we get to create the file. + */ + + handle = CreateFile(nativePath, accessMode, shareMode, + NULL, createMode, flags, NULL); + Tcl_DStringFree(&ds); + + if (handle == INVALID_HANDLE_VALUE) { + DWORD err; + + err = GetLastError(); + if ((err & 0xffffL) == ERROR_OPEN_FAILED) { + err = (mode & O_CREAT) ? ERROR_FILE_EXISTS : ERROR_FILE_NOT_FOUND; + } + TclWinConvertError(err); + return NULL; + } + + /* + * Seek to the end of file if we are writing. + */ + + if (mode & (O_WRONLY|O_APPEND)) { + SetFilePointer(handle, 0, NULL, FILE_END); + } + + return TclWinMakeFile(handle); +} + +/* + *---------------------------------------------------------------------- + * + * TclpCreateTempFile -- + * + * This function opens a unique file with the property that it will be + * deleted when its file handle is closed. The temporary file is created + * in the system temporary directory. + * + * Results: + * Returns a valid TclFile, or NULL on failure. + * + * Side effects: + * Creates a new temporary file. + * + *---------------------------------------------------------------------- + */ + +TclFile +TclpCreateTempFile( + const char *contents) /* String to write into temp file, or NULL. */ +{ + TCHAR name[MAX_PATH]; + const char *native; + Tcl_DString dstring; + HANDLE handle; + + if (TempFileName(name) == 0) { + return NULL; + } + + 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) { + goto error; + } + + /* + * Write the file out, doing line translations on the way. + */ + + if (contents != NULL) { + DWORD result, length; + const char *p; + int toCopy; + + /* + * Convert the contents from UTF to native encoding + */ + + native = Tcl_UtfToExternalDString(NULL, contents, -1, &dstring); + + toCopy = Tcl_DStringLength(&dstring); + for (p = native; toCopy > 0; p++, toCopy--) { + if (*p == '\n') { + length = p - native; + if (length > 0) { + if (!WriteFile(handle, native, length, &result, NULL)) { + goto error; + } + } + if (!WriteFile(handle, "\r\n", 2, &result, NULL)) { + goto error; + } + native = p+1; + } + } + length = p - native; + if (length > 0) { + if (!WriteFile(handle, native, length, &result, NULL)) { + goto error; + } + } + Tcl_DStringFree(&dstring); + if (SetFilePointer(handle, 0, NULL, FILE_BEGIN) == 0xFFFFFFFF) { + goto error; + } + } + + return TclWinMakeFile(handle); + + error: + /* + * Free the native representation of the contents if necessary. + */ + + if (contents != NULL) { + Tcl_DStringFree(&dstring); + } + + TclWinConvertError(GetLastError()); + CloseHandle(handle); + DeleteFile(name); + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TclpTempFileName -- + * + * This function returns a unique filename. + * + * Results: + * Returns a valid Tcl_Obj* with refCount 0, or NULL on failure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclpTempFileName(void) +{ + TCHAR fileName[MAX_PATH]; + + if (TempFileName(fileName) == 0) { + return NULL; + } + + return TclpNativeToNormalized(fileName); +} + +/* + *---------------------------------------------------------------------- + * + * TclpCreatePipe -- + * + * Creates an anonymous pipe. + * + * Results: + * Returns 1 on success, 0 on failure. + * + * Side effects: + * Creates a pipe. + * + *---------------------------------------------------------------------- + */ + +int +TclpCreatePipe( + TclFile *readPipe, /* Location to store file handle for read side + * of pipe. */ + TclFile *writePipe) /* Location to store file handle for write + * side of pipe. */ +{ + HANDLE readHandle, writeHandle; + + if (CreatePipe(&readHandle, &writeHandle, NULL, 0) != 0) { + *readPipe = TclWinMakeFile(readHandle); + *writePipe = TclWinMakeFile(writeHandle); + return 1; + } + + TclWinConvertError(GetLastError()); + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclpCloseFile -- + * + * Closes a pipeline file handle. These handles are created by + * TclpOpenFile, TclpCreatePipe, or TclpMakeFile. + * + * Results: + * 0 on success, -1 on failure. + * + * Side effects: + * The file is closed and deallocated. + * + *---------------------------------------------------------------------- + */ + +int +TclpCloseFile( + TclFile file) /* The file to close. */ +{ + WinFile *filePtr = (WinFile *) file; + + switch (filePtr->type) { + case WIN_FILE: + /* + * 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 another. + */ + + if (!TclInThreadExit() + || ((GetStdHandle(STD_INPUT_HANDLE) != filePtr->handle) + && (GetStdHandle(STD_OUTPUT_HANDLE) != filePtr->handle) + && (GetStdHandle(STD_ERROR_HANDLE) != filePtr->handle))) { + if (filePtr->handle != NULL && + CloseHandle(filePtr->handle) == FALSE) { + TclWinConvertError(GetLastError()); + ckfree(filePtr); + return -1; + } + } + break; + + default: + Tcl_Panic("TclpCloseFile: unexpected file type"); + } + + ckfree(filePtr); + return 0; +} + +/* + *-------------------------------------------------------------------------- + * + * TclpGetPid -- + * + * Given a HANDLE to a child process, return the process id for that + * child process. + * + * Results: + * Returns the process id for the child process. If the pid was not known + * by Tcl, either because the pid was not created by Tcl or the child + * process has already been reaped, -1 is returned. + * + * Side effects: + * None. + * + *-------------------------------------------------------------------------- + */ + +int +TclpGetPid( + Tcl_Pid pid) /* The HANDLE of the child process. */ +{ + ProcInfo *infoPtr; + + PipeInit(); + + Tcl_MutexLock(&pipeMutex); + for (infoPtr = procList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { + if (infoPtr->hProcess == (HANDLE) pid) { + Tcl_MutexUnlock(&pipeMutex); + return infoPtr->dwProcessId; + } + } + Tcl_MutexUnlock(&pipeMutex); + return (unsigned long) -1; +} + +/* + *---------------------------------------------------------------------- + * + * TclpCreateProcess -- + * + * Create a child process that has the specified files as its standard + * input, output, and error. The child process runs asynchronously under + * Windows NT and Windows 9x, and runs with the same environment + * variables as the creating process. + * + * 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 standard extensions to the + * executable name. + * + * Results: + * The return value is TCL_ERROR and an error message is left in the + * interp's result if there was a problem creating the child process. + * Otherwise, the return value is TCL_OK and *pidPtr is filled with the + * process id of the child process. + * + * Side effects: + * A process is created. + * + *---------------------------------------------------------------------- + */ + +int +TclpCreateProcess( + Tcl_Interp *interp, /* Interpreter in which to leave errors that + * occurred when creating the child process. + * Error messages from the child process + * itself are sent to errorFile. */ + int argc, /* Number of arguments in following array. */ + const char **argv, /* Array of argument strings. argv[0] contains + * the name of the executable converted to + * native format (using the + * Tcl_TranslateFileName call). Additional + * arguments have not been converted. */ + TclFile inputFile, /* If non-NULL, gives the file to use as input + * for the child process. If inputFile file is + * not readable or is NULL, the child will + * receive no standard input. */ + TclFile outputFile, /* If non-NULL, gives the file that receives + * output from the child process. If + * outputFile file is not writeable or is + * NULL, output from the child will be + * discarded. */ + TclFile errorFile, /* If non-NULL, gives the file that receives + * errors from the child process. If errorFile + * file is not writeable or is NULL, errors + * from the child will be discarded. errorFile + * may be the same as outputFile. */ + Tcl_Pid *pidPtr) /* If this function is successful, pidPtr is + * filled with the process id of the child + * process. */ +{ + int result, applType, createFlags; + Tcl_DString cmdLine; /* Complete command line (TCHAR). */ + STARTUPINFO startInfo; + PROCESS_INFORMATION procInfo; + SECURITY_ATTRIBUTES secAtts; + HANDLE hProcess, h, inputHandle, outputHandle, errorHandle; + char execPath[MAX_PATH * TCL_UTF_MAX]; + WinFile *filePtr; + + PipeInit(); + + applType = ApplicationType(interp, argv[0], execPath); + if (applType == APPL_NONE) { + return TCL_ERROR; + } + + result = TCL_ERROR; + Tcl_DStringInit(&cmdLine); + hProcess = GetCurrentProcess(); + + /* + * STARTF_USESTDHANDLES must be used to pass handles to child process. + * Using SetStdHandle() and/or dup2() only works when a console mode + * parent process is spawning an attached console mode child process. + */ + + ZeroMemory(&startInfo, sizeof(startInfo)); + startInfo.cb = sizeof(startInfo); + startInfo.dwFlags = STARTF_USESTDHANDLES; + startInfo.hStdInput = INVALID_HANDLE_VALUE; + startInfo.hStdOutput= INVALID_HANDLE_VALUE; + startInfo.hStdError = INVALID_HANDLE_VALUE; + + secAtts.nLength = sizeof(SECURITY_ATTRIBUTES); + secAtts.lpSecurityDescriptor = NULL; + secAtts.bInheritHandle = TRUE; + + /* + * We have to check the type of each file, since we cannot duplicate some + * file types. + */ + + inputHandle = INVALID_HANDLE_VALUE; + if (inputFile != NULL) { + filePtr = (WinFile *)inputFile; + if (filePtr->type == WIN_FILE) { + inputHandle = filePtr->handle; + } + } + outputHandle = INVALID_HANDLE_VALUE; + if (outputFile != NULL) { + filePtr = (WinFile *)outputFile; + if (filePtr->type == WIN_FILE) { + outputHandle = filePtr->handle; + } + } + errorHandle = INVALID_HANDLE_VALUE; + if (errorFile != NULL) { + filePtr = (WinFile *)errorFile; + if (filePtr->type == WIN_FILE) { + errorHandle = filePtr->handle; + } + } + + /* + * Duplicate all the handles which will be passed off as stdin, stdout and + * stderr of the child process. The duplicate handles are set to be + * inheritable, so the child process can use them. + */ + + if (inputHandle == INVALID_HANDLE_VALUE) { + /* + * If handle was not set, stdin should return immediate EOF. Under + * Windows95, some applications (both 16 and 32 bit!) cannot read from + * the NUL device; they read from console instead. When running tk, + * this is fatal because the child process would hang forever waiting + * for EOF from the unmapped console window used by the helper + * application. + * + * Fortunately, the helper application detects a closed pipe as an + * immediate EOF and can pass that information to the child process. + */ + + if (CreatePipe(&startInfo.hStdInput, &h, &secAtts, 0) != FALSE) { + CloseHandle(h); + } + } else { + DuplicateHandle(hProcess, inputHandle, hProcess, &startInfo.hStdInput, + 0, TRUE, DUPLICATE_SAME_ACCESS); + } + if (startInfo.hStdInput == INVALID_HANDLE_VALUE) { + TclWinConvertError(GetLastError()); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't duplicate input handle: %s", + Tcl_PosixError(interp))); + goto end; + } + + if (outputHandle == INVALID_HANDLE_VALUE) { + /* + * If handle was not set, output should be sent to an infinitely deep + * sink. Under Windows 95, some 16 bit applications cannot have stdout + * redirected to NUL; they send their output to the console instead. + * Some applications, like "more" or "dir /p", when outputting + * multiple pages to the console, also then try and read from the + * console to go the next page. When running tk, this is fatal because + * the child process would hang forever waiting for input from the + * unmapped console window used by the helper application. + * + * Fortunately, the helper application will detect a closed pipe as a + * sink. + */ + + 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_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't duplicate output handle: %s", + Tcl_PosixError(interp))); + goto end; + } + + if (errorHandle == INVALID_HANDLE_VALUE) { + /* + * If handle was not set, errors should be sent to an infinitely deep + * sink. + */ + + startInfo.hStdError = CreateFile(TEXT("NUL:"), GENERIC_WRITE, 0, + &secAtts, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); + } else { + DuplicateHandle(hProcess, errorHandle, hProcess, &startInfo.hStdError, + 0, TRUE, DUPLICATE_SAME_ACCESS); + } + if (startInfo.hStdError == INVALID_HANDLE_VALUE) { + TclWinConvertError(GetLastError()); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't duplicate error handle: %s", + Tcl_PosixError(interp))); + goto end; + } + + /* + * If we do not have a console window, then we must run DOS and WIN32 + * console mode applications as detached processes. This tells the loader + * that the child application should not inherit the console, and that it + * should not create a new console window for the child application. The + * child application should get its stdio from the redirection handles + * provided by this application, and run in the background. + * + * If we are starting a GUI process, they don't automatically get a + * console, so it doesn't matter if they are started as foreground or + * detached processes. The GUI window will still pop up to the foreground. + */ + + if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_NT) { + if (HasConsole()) { + createFlags = 0; + } else if (applType == APPL_DOS) { + /* + * Under NT, 16-bit DOS applications will not run unless they can + * be attached to a console. If we are running without a console, + * run the 16-bit program as an normal process inside of a hidden + * console application, and then run that hidden console as a + * detached process. + */ + + startInfo.wShowWindow = SW_HIDE; + startInfo.dwFlags |= STARTF_USESHOWWINDOW; + createFlags = CREATE_NEW_CONSOLE; + TclDStringAppendLiteral(&cmdLine, "cmd.exe /c"); + } else { + createFlags = DETACHED_PROCESS; + } + } else { + if (HasConsole()) { + createFlags = 0; + } else { + createFlags = DETACHED_PROCESS; + } + + if (applType == APPL_DOS) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "DOS application process not supported on this platform", + -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "DOS_APP", + NULL); + goto end; + } + } + + /* + * cmdLine gets the full command line used to invoke the executable, + * including the name of the executable itself. The command line arguments + * in argv[] are stored in cmdLine separated by spaces. Special characters + * in individual arguments from argv[] must be quoted when being stored in + * cmdLine. + * + * When calling any application, bear in mind that arguments that specify + * a path name are not converted. If an argument contains forward slashes + * as path separators, it may or may not be recognized as a path name, + * depending on the program. In general, most applications accept forward + * slashes only as option delimiters and backslashes only as paths. + * + * Additionally, when calling a 16-bit dos or windows application, all + * path names must use the short, cryptic, path format (e.g., using + * ab~1.def instead of "a b.default"). + */ + + BuildCommandLine(execPath, argc, argv, &cmdLine); + + if (CreateProcess(NULL, (TCHAR *) Tcl_DStringValue(&cmdLine), + NULL, NULL, TRUE, (DWORD) createFlags, NULL, NULL, &startInfo, + &procInfo) == 0) { + TclWinConvertError(GetLastError()); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("couldn't execute \"%s\": %s", + argv[0], Tcl_PosixError(interp))); + goto end; + } + + /* + * This wait is used to force the OS to give some time to the DOS process. + */ + + if (applType == APPL_DOS) { + WaitForSingleObject(procInfo.hProcess, 50); + } + + /* + * "When an application spawns a process repeatedly, a new thread instance + * will be created for each process but the previous instances may not be + * cleaned up. This results in a significant virtual memory loss each time + * the process is spawned. If there is a WaitForInputIdle() call between + * CreateProcess() and CloseHandle(), the problem does not occur." PSS ID + * Number: Q124121 + */ + + WaitForInputIdle(procInfo.hProcess, 5000); + CloseHandle(procInfo.hThread); + + *pidPtr = (Tcl_Pid) procInfo.hProcess; + if (*pidPtr != 0) { + TclWinAddProcess(procInfo.hProcess, procInfo.dwProcessId); + } + result = TCL_OK; + + end: + Tcl_DStringFree(&cmdLine); + if (startInfo.hStdInput != INVALID_HANDLE_VALUE) { + CloseHandle(startInfo.hStdInput); + } + if (startInfo.hStdOutput != INVALID_HANDLE_VALUE) { + CloseHandle(startInfo.hStdOutput); + } + if (startInfo.hStdError != INVALID_HANDLE_VALUE) { + CloseHandle(startInfo.hStdError); + } + return result; +} + + +/* + *---------------------------------------------------------------------- + * + * HasConsole -- + * + * Determines whether the current application is attached to a console. + * + * Results: + * Returns TRUE if this application has a console, else FALSE. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static BOOL +HasConsole(void) +{ + HANDLE handle; + + handle = CreateFileA("CONOUT$", GENERIC_WRITE, FILE_SHARE_WRITE, + NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL); + + if (handle != INVALID_HANDLE_VALUE) { + CloseHandle(handle); + return TRUE; + } else { + return FALSE; + } +} + +/* + *-------------------------------------------------------------------- + * + * ApplicationType -- + * + * Search for the specified program and identify if it refers to a DOS, + * Windows 3.X, or Win32 program. Used to determine how to invoke a + * program, or if it can even be invoked. + * + * It is possible to almost positively identify DOS and Windows + * applications that contain the appropriate magic numbers. However, DOS + * .com files do not seem to contain a magic number; if the program name + * ends with .com and could not be identified as a Windows .com file, it + * will be assumed to be a DOS application, even if it was just random + * data. If the program name does not end with .com, no such assumption + * is made. + * + * The Win32 function GetBinaryType incorrectly identifies any junk file + * that ends with .exe as a dos executable and some executables that + * don't end with .exe as not executable. Plus it doesn't exist under + * win95, so I won't feel bad about reimplementing functionality. + * + * Results: + * The return value is one of APPL_DOS, APPL_WIN3X, or APPL_WIN32 if the + * filename referred to the corresponding application type. If the file + * name could not be found or did not refer to any known application + * type, APPL_NONE is returned and an error message is left in interp. + * .bat files are identified as APPL_DOS. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ApplicationType( + Tcl_Interp *interp, /* Interp, for error message. */ + const char *originalName, /* Name of the application to find. */ + char fullName[]) /* Filled with complete path to + * application. */ +{ + int applType, i, nameLen, found; + HANDLE hFile; + TCHAR *rest; + char *ext; + char buf[2]; + DWORD attr, read; + IMAGE_DOS_HEADER header; + Tcl_DString nameBuf, ds; + const TCHAR *nativeName; + TCHAR nativeFullPath[MAX_PATH]; + static const char extensions[][5] = {"", ".com", ".exe", ".bat", ".cmd"}; + + /* + * Look for the program as an external program. First try the name as it + * is, then try adding .com, .exe, and .bat, in that order, to the name, + * looking for an executable. + * + * Using the raw SearchPath() function doesn't do quite what is necessary. + * If the name of the executable already contains a '.' character, it will + * not try appending the specified extension when searching (in other + * words, SearchPath will not find the program "a.b.exe" if the arguments + * specified "a.b" and ".exe"). So, first look for the file as it is + * named. Then manually append the extensions, looking for a match. + */ + + applType = APPL_NONE; + Tcl_DStringInit(&nameBuf); + Tcl_DStringAppend(&nameBuf, originalName, -1); + nameLen = Tcl_DStringLength(&nameBuf); + + for (i = 0; i < (int) (sizeof(extensions) / sizeof(extensions[0])); i++) { + Tcl_DStringSetLength(&nameBuf, nameLen); + Tcl_DStringAppend(&nameBuf, extensions[i], -1); + nativeName = Tcl_WinUtfToTChar(Tcl_DStringValue(&nameBuf), + Tcl_DStringLength(&nameBuf), &ds); + found = SearchPath(NULL, nativeName, NULL, MAX_PATH, + nativeFullPath, &rest); + Tcl_DStringFree(&ds); + if (found == 0) { + continue; + } + + /* + * Ignore matches on directories or data files, return if identified a + * known type. + */ + + attr = GetFileAttributes(nativeFullPath); + if ((attr == 0xffffffff) || (attr & FILE_ATTRIBUTE_DIRECTORY)) { + continue; + } + strcpy(fullName, Tcl_WinTCharToUtf(nativeFullPath, -1, &ds)); + Tcl_DStringFree(&ds); + + ext = strrchr(fullName, '.'); + if ((ext != NULL) && + (strcasecmp(ext, ".cmd") == 0 || strcasecmp(ext, ".bat") == 0)) { + applType = APPL_DOS; + break; + } + + hFile = CreateFile(nativeFullPath, + GENERIC_READ, FILE_SHARE_READ, NULL, OPEN_EXISTING, + FILE_ATTRIBUTE_NORMAL, NULL); + if (hFile == INVALID_HANDLE_VALUE) { + continue; + } + + header.e_magic = 0; + ReadFile(hFile, (void *) &header, sizeof(header), &read, NULL); + if (header.e_magic != IMAGE_DOS_SIGNATURE) { + /* + * Doesn't have the magic number for relocatable executables. If + * filename ends with .com, assume it's a DOS application anyhow. + * Note that we didn't make this assumption at first, because some + * supposed .com files are really 32-bit executables with all the + * magic numbers and everything. + */ + + CloseHandle(hFile); + if ((ext != NULL) && (strcasecmp(ext, ".com") == 0)) { + applType = APPL_DOS; + break; + } + continue; + } + if (header.e_lfarlc != sizeof(header)) { + /* + * All Windows 3.X and Win32 and some DOS programs have this value + * set here. If it doesn't, assume that since it already had the + * other magic number it was a DOS application. + */ + + CloseHandle(hFile); + applType = APPL_DOS; + break; + } + + /* + * The DWORD at header.e_lfanew points to yet another magic number. + */ + + buf[0] = '\0'; + SetFilePointer(hFile, header.e_lfanew, NULL, FILE_BEGIN); + ReadFile(hFile, (void *) buf, 2, &read, NULL); + CloseHandle(hFile); + + if ((buf[0] == 'N') && (buf[1] == 'E')) { + applType = APPL_WIN3X; + } else if ((buf[0] == 'P') && (buf[1] == 'E')) { + applType = APPL_WIN32; + } else { + /* + * Strictly speaking, there should be a test that there is an 'L' + * and 'E' at buf[0..1], to identify the type as DOS, but of + * course we ran into a DOS executable that _doesn't_ have the + * magic number - specifically, one compiled using the Lahey + * Fortran90 compiler. + */ + + applType = APPL_DOS; + } + break; + } + Tcl_DStringFree(&nameBuf); + + if (applType == APPL_NONE) { + TclWinConvertError(GetLastError()); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("couldn't execute \"%s\": %s", + originalName, Tcl_PosixError(interp))); + return APPL_NONE; + } + + if ((applType == APPL_DOS) || (applType == APPL_WIN3X)) { + /* + * Replace long path name of executable with short path name for + * 16-bit applications. Otherwise the application may not be able to + * correctly parse its own command line to separate off the + * application name from the arguments. + */ + + GetShortPathName(nativeFullPath, nativeFullPath, MAX_PATH); + strcpy(fullName, Tcl_WinTCharToUtf(nativeFullPath, -1, &ds)); + Tcl_DStringFree(&ds); + } + return applType; +} + +/* + *---------------------------------------------------------------------- + * + * BuildCommandLine -- + * + * The command line arguments are stored in linePtr separated by spaces, + * in a form that CreateProcess() understands. Special characters in + * individual arguments from argv[] must be quoted when being stored in + * cmdLine. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +BuildCommandLine( + const char *executable, /* Full path of executable (including + * extension). Replacement for argv[0]. */ + int argc, /* Number of arguments. */ + const char **argv, /* Argument strings in UTF. */ + Tcl_DString *linePtr) /* Initialized Tcl_DString that receives the + * command line (TCHAR). */ +{ + const char *arg, *start, *special; + int quote, i; + Tcl_DString ds; + + Tcl_DStringInit(&ds); + + /* + * Prime the path. Add a space separator if we were primed with something. + */ + + TclDStringAppendDString(&ds, linePtr); + if (Tcl_DStringLength(linePtr) > 0) { + TclDStringAppendLiteral(&ds, " "); + } + + for (i = 0; i < argc; i++) { + if (i == 0) { + arg = executable; + } else { + arg = argv[i]; + TclDStringAppendLiteral(&ds, " "); + } + + quote = 0; + if (arg[0] == '\0') { + quote = 1; + } else { + int count; + Tcl_UniChar ch = 0; + + for (start = arg; *start != '\0'; start += count) { + count = TclUtfToUniChar(start, &ch); + if (Tcl_UniCharIsSpace(ch)) { /* INTL: ISO space. */ + quote = 1; + break; + } + } + } + if (quote) { + TclDStringAppendLiteral(&ds, "\""); + } + start = arg; + for (special = arg; ; ) { + if ((*special == '\\') && (special[1] == '\\' || + special[1] == '"' || (quote && special[1] == '\0'))) { + Tcl_DStringAppend(&ds, start, (int) (special - start)); + start = special; + while (1) { + special++; + if (*special == '"' || (quote && *special == '\0')) { + /* + * N backslashes followed a quote -> insert N * 2 + 1 + * backslashes then a quote. + */ + + Tcl_DStringAppend(&ds, start, + (int) (special - start)); + break; + } + if (*special != '\\') { + break; + } + } + Tcl_DStringAppend(&ds, start, (int) (special - start)); + start = special; + } + if (*special == '"') { + Tcl_DStringAppend(&ds, start, (int) (special - start)); + TclDStringAppendLiteral(&ds, "\\\""); + start = special + 1; + } + if (*special == '\0') { + break; + } + special++; + } + Tcl_DStringAppend(&ds, start, (int) (special - start)); + if (quote) { + TclDStringAppendLiteral(&ds, "\""); + } + } + Tcl_DStringFree(linePtr); + Tcl_WinUtfToTChar(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds), linePtr); + Tcl_DStringFree(&ds); +} + +/* + *---------------------------------------------------------------------- + * + * TclpCreateCommandChannel -- + * + * This function is called by Tcl_OpenCommandChannel to perform the + * platform specific channel initialization for a command channel. + * + * Results: + * Returns a new channel or NULL on failure. + * + * Side effects: + * Allocates a new channel. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +TclpCreateCommandChannel( + TclFile readFile, /* If non-null, gives the file for reading. */ + TclFile writeFile, /* If non-null, gives the file for writing. */ + TclFile errorFile, /* If non-null, gives the file where errors + * can be read. */ + int numPids, /* The number of pids in the pid array. */ + Tcl_Pid *pidPtr) /* An array of process identifiers. */ +{ + char channelName[16 + TCL_INTEGER_SPACE]; + PipeInfo *infoPtr = ckalloc(sizeof(PipeInfo)); + + PipeInit(); + + infoPtr->watchMask = 0; + infoPtr->flags = 0; + infoPtr->readFlags = 0; + infoPtr->readFile = readFile; + infoPtr->writeFile = writeFile; + infoPtr->errorFile = errorFile; + infoPtr->numPids = numPids; + infoPtr->pidPtr = pidPtr; + infoPtr->writeBuf = 0; + infoPtr->writeBufLen = 0; + infoPtr->writeError = 0; + infoPtr->channel = NULL; + + infoPtr->validMask = 0; + + infoPtr->threadId = Tcl_GetCurrentThread(); + + if (readFile != NULL) { + /* + * Start the background reader thread. + */ + + infoPtr->readable = CreateEvent(NULL, TRUE, TRUE, NULL); + infoPtr->readThread = CreateThread(NULL, 256, PipeReaderThread, + 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) { + /* + * Start the background writer thread. + */ + + infoPtr->writable = CreateEvent(NULL, TRUE, TRUE, NULL); + infoPtr->writeThread = CreateThread(NULL, 256, PipeWriterThread, + 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; + } + + /* + * For backward compatibility with previous versions of Tcl, we use + * "file%d" as the base name for pipes even though it would be more + * natural to use "pipe%d". Use the pointer to keep the channel names + * unique, in case channels share handles (stdin/stdout). + */ + + sprintf(channelName, "file%" TCL_I_MODIFIER "x", (size_t) infoPtr); + infoPtr->channel = Tcl_CreateChannel(&pipeChannelType, channelName, + infoPtr, infoPtr->validMask); + + /* + * Pipes have AUTO translation mode on Windows and ^Z eof char, which + * means that a ^Z will be appended to them at close. This is needed for + * Windows programs that expect a ^Z at EOF. + */ + + 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 + * interp's result. + * + * Results: + * None. + * + * Side effects: + * Modifies the interp's result. + * + *---------------------------------------------------------------------- + */ + +void +TclGetAndDetachPids( + Tcl_Interp *interp, + Tcl_Channel chan) +{ + PipeInfo *pipePtr; + const Tcl_ChannelType *chanTypePtr; + Tcl_Obj *pidsObj; + int i; + + /* + * Punt if the channel is not a command channel. + */ + + chanTypePtr = Tcl_GetChannelType(chan); + if (chanTypePtr != &pipeChannelType) { + return; + } + + pipePtr = Tcl_GetChannelInstanceData(chan); + TclNewObj(pidsObj); + for (i = 0; i < pipePtr->numPids; 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(pipePtr->pidPtr); + pipePtr->numPids = 0; + } +} + +/* + *---------------------------------------------------------------------- + * + * PipeBlockModeProc -- + * + * Set blocking or non-blocking mode on channel. + * + * Results: + * 0 if successful, errno when failed. + * + * Side effects: + * Sets the device into blocking or non-blocking mode. + * + *---------------------------------------------------------------------- + */ + +static int +PipeBlockModeProc( + ClientData instanceData, /* Instance data for channel. */ + int mode) /* TCL_MODE_BLOCKING or + * TCL_MODE_NONBLOCKING. */ +{ + PipeInfo *infoPtr = (PipeInfo *) instanceData; + + /* + * Pipes on Windows can not be switched between blocking and nonblocking, + * hence we have to emulate the behavior. This is done in the input + * function by checking against a bit in the state. We set or unset the + * bit here to cause the input function to emulate the correct behavior. + */ + + if (mode == TCL_MODE_NONBLOCKING) { + infoPtr->flags |= PIPE_ASYNC; + } else { + infoPtr->flags &= ~(PIPE_ASYNC); + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * PipeClose2Proc -- + * + * Closes a pipe based IO channel. + * + * Results: + * 0 on success, errno otherwise. + * + * Side effects: + * Closes the physical channel. + * + *---------------------------------------------------------------------- + */ + +static int +PipeClose2Proc( + ClientData instanceData, /* Pointer to PipeInfo structure. */ + Tcl_Interp *interp, /* For error reporting. */ + int flags) /* Flags that indicate which side to close. */ +{ + PipeInfo *pipePtr = (PipeInfo *) instanceData; + Tcl_Channel errChan; + int errorCode, result; + PipeInfo *infoPtr, **nextPtrPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + int inExit = (TclInExit() || TclInThreadExit()); + + errorCode = 0; + result = 0; + + 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 + * trying to read from the pipe. + */ + + if (pipePtr->readThread) { + + TclPipeThreadStop(&pipePtr->readTI, pipePtr->readThread); + CloseHandle(pipePtr->readThread); + CloseHandle(pipePtr->readable); + pipePtr->readThread = NULL; + } + if (TclpCloseFile(pipePtr->readFile) != 0) { + errorCode = errno; + } + pipePtr->validMask &= ~TCL_READABLE; + pipePtr->readFile = 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 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) { + + /* give it a chance to leave honorably */ + TclPipeThreadStopSignal(&pipePtr->writeTI, pipePtr->writable); + + if (WaitForSingleObject(pipePtr->writable, 20) == WAIT_TIMEOUT) { + return EWOULDBLOCK; + } + + } else { + + WaitForSingleObject(pipePtr->writable, inExit ? 5000 : INFINITE); + + } + + TclPipeThreadStop(&pipePtr->writeTI, pipePtr->writeThread); + + CloseHandle(pipePtr->writable); + CloseHandle(pipePtr->writeThread); + pipePtr->writeThread = NULL; + } + if (TclpCloseFile(pipePtr->writeFile) != 0) { + if (errorCode == 0) { + errorCode = errno; + } + } + pipePtr->validMask &= ~TCL_WRITABLE; + pipePtr->writeFile = NULL; + } + + pipePtr->watchMask &= pipePtr->validMask; + + /* + * Don't free the channel if any of the flags were set. + */ + + if (flags) { + return errorCode; + } + + /* + * Remove the file from the list of watched files. + */ + + for (nextPtrPtr = &(tsdPtr->firstPipePtr), infoPtr = *nextPtrPtr; + infoPtr != NULL; + nextPtrPtr = &infoPtr->nextPtr, infoPtr = *nextPtrPtr) { + if (infoPtr == (PipeInfo *)pipePtr) { + *nextPtrPtr = infoPtr->nextPtr; + break; + } + } + + 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 + * dynamic load module), and discard the errorFile. + */ + + Tcl_DetachPids(pipePtr->numPids, pipePtr->pidPtr); + Tcl_ReapDetachedProcs(); + + if (pipePtr->errorFile) { + if (TclpCloseFile(pipePtr->errorFile) != 0) { + if (errorCode == 0) { + errorCode = errno; + } + } + } + result = 0; + } else { + /* + * Wrap the error file into a channel and give it to the cleanup + * routine. + */ + + if (pipePtr->errorFile) { + WinFile *filePtr = (WinFile *) pipePtr->errorFile; + + errChan = Tcl_MakeFileChannel((ClientData) filePtr->handle, + TCL_READABLE); + ckfree(filePtr); + } else { + errChan = NULL; + } + + result = TclCleanupChildren(interp, pipePtr->numPids, + pipePtr->pidPtr, errChan); + } + + if (pipePtr->numPids > 0) { + ckfree(pipePtr->pidPtr); + } + + if (pipePtr->writeBuf != NULL) { + ckfree(pipePtr->writeBuf); + } + + ckfree(pipePtr); + + if (errorCode == 0) { + return result; + } + return errorCode; +} + +/* + *---------------------------------------------------------------------- + * + * PipeInputProc -- + * + * Reads input from the IO channel into the buffer given. Returns count + * of how many bytes were actually read, and an error indication. + * + * Results: + * A count of how many bytes were read is returned and an error + * indication is returned in an output argument. + * + * Side effects: + * Reads input from the actual channel. + * + *---------------------------------------------------------------------- + */ + +static int +PipeInputProc( + ClientData instanceData, /* Pipe state. */ + char *buf, /* Where to store data read. */ + int bufSize, /* How much space is available in the + * buffer? */ + int *errorCode) /* Where to store error code. */ +{ + PipeInfo *infoPtr = (PipeInfo *) instanceData; + WinFile *filePtr = (WinFile*) infoPtr->readFile; + DWORD count, bytesRead = 0; + int result; + + *errorCode = 0; + /* + * Synchronize with the reader thread. + */ + + result = WaitForRead(infoPtr, (infoPtr->flags & PIPE_ASYNC) ? 0 : 1); + + /* + * If an error occurred, return immediately. + */ + + if (result == -1) { + *errorCode = errno; + return -1; + } + + if (infoPtr->readFlags & PIPE_EXTRABYTE) { + /* + * The reader thread consumed 1 byte as a side effect of waiting so we + * need to move it into the buffer. + */ + + *buf = infoPtr->extraByte; + infoPtr->readFlags &= ~PIPE_EXTRABYTE; + buf++; + bufSize--; + bytesRead = 1; + + /* + * If further read attempts would block, return what we have. + */ + + if (result == 0) { + return bytesRead; + } + } + + /* + * Attempt to read bufSize bytes. The read will return immediately if + * there is any data available. Otherwise it will block until at least one + * byte is available or an EOF occurs. + */ + + if (ReadFile(filePtr->handle, (LPVOID) buf, (DWORD) bufSize, &count, + (LPOVERLAPPED) NULL) == TRUE) { + return bytesRead + count; + } else if (bytesRead) { + /* + * Ignore errors if we have data to return. + */ + + return bytesRead; + } + + TclWinConvertError(GetLastError()); + if (errno == EPIPE) { + infoPtr->readFlags |= PIPE_EOF; + return 0; + } + *errorCode = errno; + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * PipeOutputProc -- + * + * Writes the given output on the IO channel. Returns count of how many + * characters were actually written, and an error indication. + * + * Results: + * A count of how many characters were written is returned and an error + * indication is returned in an output argument. + * + * Side effects: + * Writes output on the actual channel. + * + *---------------------------------------------------------------------- + */ + +static int +PipeOutputProc( + ClientData instanceData, /* Pipe state. */ + const char *buf, /* The data buffer. */ + int toWrite, /* How many bytes to write? */ + int *errorCode) /* Where to store error code. */ +{ + PipeInfo *infoPtr = (PipeInfo *) instanceData; + WinFile *filePtr = (WinFile*) infoPtr->writeFile; + DWORD bytesWritten, timeout; + + *errorCode = 0; + + /* 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 = EWOULDBLOCK; + goto error; + } + + /* + * Check for a background error on the last write. + */ + + if (infoPtr->writeError) { + TclWinConvertError(infoPtr->writeError); + infoPtr->writeError = 0; + goto error; + } + + if (infoPtr->flags & PIPE_ASYNC) { + /* + * The pipe is non-blocking, so copy the data into the output buffer + * and restart the writer thread. + */ + + if (toWrite > infoPtr->writeBufLen) { + /* + * Reallocate the buffer to be large enough to hold the data. + */ + + if (infoPtr->writeBuf) { + ckfree(infoPtr->writeBuf); + } + infoPtr->writeBufLen = toWrite; + infoPtr->writeBuf = ckalloc(toWrite); + } + memcpy(infoPtr->writeBuf, buf, (size_t) toWrite); + infoPtr->toWrite = toWrite; + ResetEvent(infoPtr->writable); + TclPipeThreadSignal(&infoPtr->writeTI); + bytesWritten = toWrite; + } else { + /* + * In the blocking case, just try to write the buffer directly. This + * avoids an unnecessary copy. + */ + + if (WriteFile(filePtr->handle, (LPVOID) buf, (DWORD) toWrite, + &bytesWritten, (LPOVERLAPPED) NULL) == FALSE) { + TclWinConvertError(GetLastError()); + goto error; + } + } + return bytesWritten; + + error: + *errorCode = errno; + return -1; + +} + +/* + *---------------------------------------------------------------------- + * + * PipeEventProc -- + * + * This function is invoked by Tcl_ServiceEvent when a file event reaches + * the front of the event queue. This function invokes Tcl_NotifyChannel + * on the pipe. + * + * 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. + * + * Side effects: + * Whatever the notifier callback does. + * + *---------------------------------------------------------------------- + */ + +static int +PipeEventProc( + Tcl_Event *evPtr, /* Event to service. */ + int flags) /* Flags that indicate what events to + * handle, such as TCL_FILE_EVENTS. */ +{ + PipeEvent *pipeEvPtr = (PipeEvent *)evPtr; + PipeInfo *infoPtr; + int mask; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if (!(flags & TCL_FILE_EVENTS)) { + return 0; + } + + /* + * Search through the list of watched pipes for the one whose handle + * matches the event. We do this rather than simply dereferencing the + * handle in the event so that pipes can be deleted while the event is in + * the queue. + */ + + for (infoPtr = tsdPtr->firstPipePtr; infoPtr != NULL; + infoPtr = infoPtr->nextPtr) { + if (pipeEvPtr->infoPtr == infoPtr) { + infoPtr->flags &= ~(PIPE_PENDING); + break; + } + } + + /* + * Remove stale events. + */ + + if (!infoPtr) { + return 1; + } + + /* + * Check to see if the pipe is readable. Note that we can't tell if a pipe + * is writable, so we always report it as being writable unless we have + * detected EOF. + */ + + mask = 0; + if ((infoPtr->watchMask & TCL_WRITABLE) && + (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT)) { + mask = TCL_WRITABLE; + } + + if ((infoPtr->watchMask & TCL_READABLE) && (WaitForRead(infoPtr,0) >= 0)) { + if (infoPtr->readFlags & PIPE_EOF) { + mask = TCL_READABLE; + } else { + mask |= TCL_READABLE; + } + } + + /* + * Inform the channel of the events. + */ + + Tcl_NotifyChannel(infoPtr->channel, infoPtr->watchMask & mask); + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * PipeWatchProc -- + * + * Called by the notifier to set up to watch for events on this channel. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +PipeWatchProc( + ClientData instanceData, /* Pipe state. */ + int mask) /* What events to watch for, OR-ed combination + * of TCL_READABLE, TCL_WRITABLE and + * TCL_EXCEPTION. */ +{ + PipeInfo **nextPtrPtr, *ptr; + PipeInfo *infoPtr = (PipeInfo *) instanceData; + int oldMask = infoPtr->watchMask; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + /* + * Since most of the work is handled by the background threads, we just + * need to update the watchMask and then force the notifier to poll once. + */ + + infoPtr->watchMask = mask & infoPtr->validMask; + if (infoPtr->watchMask) { + Tcl_Time blockTime = { 0, 0 }; + if (!oldMask) { + infoPtr->nextPtr = tsdPtr->firstPipePtr; + tsdPtr->firstPipePtr = infoPtr; + } + Tcl_SetMaxBlockTime(&blockTime); + } else { + if (oldMask) { + /* + * Remove the pipe from the list of watched pipes. + */ + + for (nextPtrPtr = &(tsdPtr->firstPipePtr), ptr = *nextPtrPtr; + ptr != NULL; + nextPtrPtr = &ptr->nextPtr, ptr = *nextPtrPtr) { + if (infoPtr == ptr) { + *nextPtrPtr = ptr->nextPtr; + break; + } + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * PipeGetHandleProc -- + * + * Called from Tcl_GetChannelHandle to retrieve OS handles from inside a + * command pipeline 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. + * + *---------------------------------------------------------------------- + */ + +static int +PipeGetHandleProc( + ClientData instanceData, /* The pipe state. */ + int direction, /* TCL_READABLE or TCL_WRITABLE */ + ClientData *handlePtr) /* Where to store the handle. */ +{ + PipeInfo *infoPtr = (PipeInfo *) instanceData; + WinFile *filePtr; + + if (direction == TCL_READABLE && infoPtr->readFile) { + filePtr = (WinFile*) infoPtr->readFile; + *handlePtr = (ClientData) filePtr->handle; + return TCL_OK; + } + if (direction == TCL_WRITABLE && infoPtr->writeFile) { + filePtr = (WinFile*) infoPtr->writeFile; + *handlePtr = (ClientData) filePtr->handle; + return TCL_OK; + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_WaitPid -- + * + * Emulates the waitpid system call. + * + * Results: + * Returns 0 if the process is still alive, -1 on an error, or the pid on + * a clean close. + * + * Side effects: + * Unless WNOHANG is set and the wait times out, the process information + * record will be deleted and the process handle will be closed. + * + *---------------------------------------------------------------------- + */ + +Tcl_Pid +Tcl_WaitPid( + Tcl_Pid pid, + int *statPtr, + int options) +{ + ProcInfo *infoPtr = NULL, **prevPtrPtr; + DWORD flags; + Tcl_Pid result; + DWORD ret, exitCode; + + PipeInit(); + + /* + * If no pid is specified, do nothing. + */ + + if (pid == 0) { + *statPtr = 0; + return 0; + } + + /* + * Find the process and cut it from the process list. + */ + + Tcl_MutexLock(&pipeMutex); + prevPtrPtr = &procList; + for (infoPtr = procList; infoPtr != NULL; + prevPtrPtr = &infoPtr->nextPtr, infoPtr = infoPtr->nextPtr) { + if (infoPtr->hProcess == (HANDLE) pid) { + *prevPtrPtr = infoPtr->nextPtr; + break; + } + } + Tcl_MutexUnlock(&pipeMutex); + + /* + * If the pid is not one of the processes we know about (we started it) + * then do nothing. + */ + + if (infoPtr == NULL) { + *statPtr = 0; + return 0; + } + + /* + * Officially "wait" for it to finish. We either poll (WNOHANG) or wait + * for an infinite amount of time. + */ + + if (options & WNOHANG) { + flags = 0; + } else { + flags = INFINITE; + } + ret = WaitForSingleObject(infoPtr->hProcess, flags); + if (ret == WAIT_TIMEOUT) { + *statPtr = 0; + if (options & WNOHANG) { + /* + * Re-insert this infoPtr back on the list. + */ + + Tcl_MutexLock(&pipeMutex); + infoPtr->nextPtr = procList; + procList = infoPtr; + Tcl_MutexUnlock(&pipeMutex); + return 0; + } else { + result = 0; + } + } else if (ret == WAIT_OBJECT_0) { + GetExitCodeProcess(infoPtr->hProcess, &exitCode); + + /* + * Does the exit code look like one of the exception codes? + */ + + switch (exitCode) { + case EXCEPTION_FLT_DENORMAL_OPERAND: + case EXCEPTION_FLT_DIVIDE_BY_ZERO: + case EXCEPTION_FLT_INEXACT_RESULT: + case EXCEPTION_FLT_INVALID_OPERATION: + case EXCEPTION_FLT_OVERFLOW: + case EXCEPTION_FLT_STACK_CHECK: + case EXCEPTION_FLT_UNDERFLOW: + case EXCEPTION_INT_DIVIDE_BY_ZERO: + case EXCEPTION_INT_OVERFLOW: + *statPtr = 0xC0000000 | SIGFPE; + break; + + case EXCEPTION_PRIV_INSTRUCTION: + case EXCEPTION_ILLEGAL_INSTRUCTION: + *statPtr = 0xC0000000 | SIGILL; + break; + + case EXCEPTION_ACCESS_VIOLATION: + case EXCEPTION_ARRAY_BOUNDS_EXCEEDED: + case EXCEPTION_STACK_OVERFLOW: + case EXCEPTION_NONCONTINUABLE_EXCEPTION: + case EXCEPTION_INVALID_DISPOSITION: + case EXCEPTION_GUARD_PAGE: + case EXCEPTION_INVALID_HANDLE: + *statPtr = 0xC0000000 | SIGSEGV; + break; + + case EXCEPTION_DATATYPE_MISALIGNMENT: + *statPtr = 0xC0000000 | SIGBUS; + break; + + case EXCEPTION_BREAKPOINT: + case EXCEPTION_SINGLE_STEP: + *statPtr = 0xC0000000 | SIGTRAP; + break; + + case CONTROL_C_EXIT: + *statPtr = 0xC0000000 | SIGINT; + break; + + default: + /* + * Non-exceptional, normal, exit code. Note that the exit code is + * truncated to a signed short range [-32768,32768) whether it + * fits into this range or not. + * + * BUG: Even though the exit code is a DWORD, it is understood by + * convention to be a signed integer, yet there isn't enough room + * to fit this into the POSIX style waitstatus mask without + * truncating it. + */ + + *statPtr = exitCode; + break; + } + result = pid; + } else { + errno = ECHILD; + *statPtr = 0xC0000000 | ECHILD; + result = (Tcl_Pid) -1; + } + + /* + * Officially close the process handle. + */ + + CloseHandle(infoPtr->hProcess); + ckfree(infoPtr); + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TclWinAddProcess -- + * + * Add a process to the process list so that we can use Tcl_WaitPid on + * the process. + * + * Results: + * None + * + * Side effects: + * Adds the specified process handle to the process list so Tcl_WaitPid + * knows about it. + * + *---------------------------------------------------------------------- + */ + +void +TclWinAddProcess( + void *hProcess, /* Handle to process */ + unsigned long id) /* Global process identifier */ +{ + ProcInfo *procPtr = ckalloc(sizeof(ProcInfo)); + + PipeInit(); + + procPtr->hProcess = hProcess; + procPtr->dwProcessId = id; + Tcl_MutexLock(&pipeMutex); + procPtr->nextPtr = procList; + procList = procPtr; + Tcl_MutexUnlock(&pipeMutex); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PidObjCmd -- + * + * This function is invoked to process the "pid" Tcl command. See the + * user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +int +Tcl_PidObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const *objv) /* Argument strings. */ +{ + Tcl_Channel chan; + const Tcl_ChannelType *chanTypePtr; + PipeInfo *pipePtr; + int i; + Tcl_Obj *resultPtr; + + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?channelId?"); + return TCL_ERROR; + } + if (objc == 1) { + Tcl_SetObjResult(interp, Tcl_NewWideIntObj((unsigned) getpid())); + } else { + chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), + NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + chanTypePtr = Tcl_GetChannelType(chan); + if (chanTypePtr != &pipeChannelType) { + return TCL_OK; + } + + pipePtr = (PipeInfo *) Tcl_GetChannelInstanceData(chan); + resultPtr = Tcl_NewObj(); + for (i = 0; i < pipePtr->numPids; i++) { + Tcl_ListObjAppendElement(/*interp*/ NULL, resultPtr, + Tcl_NewWideIntObj((unsigned) + TclpGetPid(pipePtr->pidPtr[i]))); + } + Tcl_SetObjResult(interp, resultPtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * WaitForRead -- + * + * Wait until some data is available, the pipe is at EOF or the reader + * thread is blocked waiting for data (if the channel is in non-blocking + * mode). + * + * Results: + * Returns 1 if pipe is readable. Returns 0 if there is no data on the + * pipe, but there is buffered data. Returns -1 if an error occurred. If + * an error occurred, the threads may not be synchronized. + * + * Side effects: + * Updates the shared state flags and may consume 1 byte of data from the + * pipe. If no error occurred, the reader thread is blocked waiting for a + * signal from the main thread. + * + *---------------------------------------------------------------------- + */ + +static int +WaitForRead( + PipeInfo *infoPtr, /* Pipe state. */ + int blocking) /* Indicates whether call should be blocking + * or not. */ +{ + DWORD timeout, count; + HANDLE *handle = ((WinFile *) infoPtr->readFile)->handle; + + while (1) { + /* + * Synchronize with the reader thread. + */ + + /* 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 = EWOULDBLOCK; + return -1; + } + + /* + * At this point, the two threads are synchronized, so it is safe to + * access shared state. + */ + + /* + * If the pipe has hit EOF, it is always readable. + */ + + if (infoPtr->readFlags & PIPE_EOF) { + return 1; + } + + /* + * Check to see if there is any data sitting in the pipe. + */ + + if (PeekNamedPipe(handle, (LPVOID) NULL, (DWORD) 0, + (LPDWORD) NULL, &count, (LPDWORD) NULL) != TRUE) { + TclWinConvertError(GetLastError()); + + /* + * Check to see if the peek failed because of EOF. + */ + + if (errno == EPIPE) { + infoPtr->readFlags |= PIPE_EOF; + return 1; + } + + /* + * Ignore errors if there is data in the buffer. + */ + + if (infoPtr->readFlags & PIPE_EXTRABYTE) { + return 0; + } else { + return -1; + } + } + + /* + * We found some data in the pipe, so it must be readable. + */ + + if (count > 0) { + return 1; + } + + /* + * The pipe isn't readable, but there is some data sitting in the + * buffer, so return immediately. + */ + + if (infoPtr->readFlags & PIPE_EXTRABYTE) { + return 0; + } + + /* + * There wasn't any data available, so reset the thread and try again. + */ + + ResetEvent(infoPtr->readable); + TclPipeThreadSignal(&infoPtr->readTI); + } +} + +/* + *---------------------------------------------------------------------- + * + * PipeReaderThread -- + * + * This function runs in a separate thread and waits for input to become + * available on a pipe. + * + * Results: + * None. + * + * Side effects: + * Signals the main thread when input become available. May cause the + * main thread to wake up by posting a message. May consume one byte from + * the pipe for each wait operation. Will cause a memory leak of ~4k, if + * forcefully terminated with TerminateThread(). + * + *---------------------------------------------------------------------- + */ + +static DWORD WINAPI +PipeReaderThread( + LPVOID arg) +{ + TclPipeThreadInfo *pipeTI = (TclPipeThreadInfo *)arg; + PipeInfo *infoPtr = NULL; /* access info only after success init/wait */ + HANDLE handle = NULL; + DWORD count, err; + int done = 0; + + while (!done) { + /* + * Wait for the main thread to signal before attempting to wait on the + * pipe becoming readable. + */ + 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 + * data is available after the first read, we block until we can read + * a single byte off of the pipe. + */ + + if (ReadFile(handle, NULL, 0, &count, NULL) == FALSE || + PeekNamedPipe(handle, NULL, 0, NULL, &count, NULL) == FALSE) { + /* + * The error is a result of an EOF condition, so set the EOF bit + * before signalling the main thread. + */ + + err = GetLastError(); + if (err == ERROR_BROKEN_PIPE) { + infoPtr->readFlags |= PIPE_EOF; + done = 1; + } else if (err == ERROR_INVALID_HANDLE) { + done = 1; + } + } else if (count == 0) { + if (ReadFile(handle, &(infoPtr->extraByte), 1, &count, NULL) + != FALSE) { + /* + * One byte was consumed as a side effect of waiting for the + * pipe to become readable. + */ + + infoPtr->readFlags |= PIPE_EXTRABYTE; + } else { + err = GetLastError(); + if (err == ERROR_BROKEN_PIPE) { + /* + * The error is a result of an EOF condition, so set the + * EOF bit before signalling the main thread. + */ + + infoPtr->readFlags |= PIPE_EOF; + done = 1; + } else if (err == ERROR_INVALID_HANDLE) { + done = 1; + } + } + } + + /* + * Signal the main thread by signalling the readable event and then + * waking up the notifier thread. + */ + + SetEvent(infoPtr->readable); + + /* + * Alert the foreground thread. Note that we need to treat this like a + * critical section so the foreground thread does not terminate this + * thread while we are holding a mutex in the notifier code. + */ + + Tcl_MutexLock(&pipeMutex); + if (infoPtr->threadId != NULL) { + /* + * TIP #218. When in flight ignore the event, no one will receive + * it anyway. + */ + + Tcl_ThreadAlert(infoPtr->threadId); + } + 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; +} + +/* + *---------------------------------------------------------------------- + * + * PipeWriterThread -- + * + * This function runs in a separate thread and writes data onto a pipe. + * + * Results: + * Always returns 0. + * + * Side effects: + * Signals the main thread when an output operation is completed. May + * cause the main thread to wake up by posting a message. + * + *---------------------------------------------------------------------- + */ + +static DWORD WINAPI +PipeWriterThread( + LPVOID arg) +{ + 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; + + while (!done) { + /* + * Wait for the main thread to signal before attempting to write. + */ + if (!TclPipeThreadWaitForSignal(&pipeTI)) { + /* exit */ + break; + } + + if (!infoPtr) { + infoPtr = (PipeInfo *)pipeTI->clientData; + handle = ((WinFile *) infoPtr->writeFile)->handle; + } + + buf = infoPtr->writeBuf; + toWrite = infoPtr->toWrite; + + /* + * Loop until all of the bytes are written or an error occurs. + */ + + while (toWrite > 0) { + if (WriteFile(handle, buf, toWrite, &count, NULL) == FALSE) { + infoPtr->writeError = GetLastError(); + done = 1; + break; + } else { + toWrite -= count; + buf += count; + } + } + + /* + * Signal the main thread by signalling the writable event and then + * waking up the notifier thread. + */ + + SetEvent(infoPtr->writable); + + /* + * Alert the foreground thread. Note that we need to treat this like a + * critical section so the foreground thread does not terminate this + * thread while we are holding a mutex in the notifier code. + */ + + Tcl_MutexLock(&pipeMutex); + if (infoPtr->threadId != NULL) { + /* + * TIP #218. When in flight ignore the event, no one will receive + * it anyway. + */ + + Tcl_ThreadAlert(infoPtr->threadId); + } + 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; +} + +/* + *---------------------------------------------------------------------- + * + * PipeThreadActionProc -- + * + * Insert or remove any thread local refs to this channel. + * + * Results: + * None. + * + * Side effects: + * Changes thread local list of valid channels. + * + *---------------------------------------------------------------------- + */ + +static void +PipeThreadActionProc( + ClientData instanceData, + int action) +{ + PipeInfo *infoPtr = (PipeInfo *) instanceData; + + /* + * We do not access firstPipePtr in the thread structures. This is not for + * all pipes managed by the thread, but only those we are watching. + * Removal of the filevent handlers before transfer thus takes care of + * this structure. + */ + + Tcl_MutexLock(&pipeMutex); + if (action == TCL_CHANNEL_THREAD_INSERT) { + /* + * We can't copy the thread information from the channel when the + * channel is created. At this time the channel back pointer has not + * been set yet. However in that case the threadId has already been + * set by TclpCreateCommandChannel itself, so the structure is still + * good. + */ + + PipeInit(); + if (infoPtr->channel != NULL) { + infoPtr->threadId = Tcl_GetChannelThread(infoPtr->channel); + } + } else { + infoPtr->threadId = NULL; + } + Tcl_MutexUnlock(&pipeMutex); +} + +/* + *---------------------------------------------------------------------- + * + * 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 + * fill-column: 78 + * End: + */ diff --git a/win/tclWinPort.h b/win/tclWinPort.h new file mode 100644 index 0000000..41201c7 --- /dev/null +++ b/win/tclWinPort.h @@ -0,0 +1,571 @@ +/* + * tclWinPort.h -- + * + * This header file handles porting issues that occur because of + * differences between Windows and Unix. It should be the only + * file that contains #ifdefs to handle different flavors of OS. + * + * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#ifndef _TCLWINPORT +#define _TCLWINPORT + +#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 + +/* Compatibility to older visual studio / windows platform SDK */ +#if !defined(MAXULONG_PTR) +typedef DWORD DWORD_PTR; +typedef DWORD_PTR * PDWORD_PTR; +#endif + +/* + * Ask for the winsock function typedefs, also. + */ +#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 +# define UNICODE +# define __TCHAR_DEFINED + typedef float *_TCHAR; +# define _TCHAR_DEFINED + typedef float *TCHAR; +#endif /* CHECK_UNICODE_CALLS */ + +/* + * Pull in the typedef of TCHAR for windows. + */ +#include <tchar.h> +#ifndef _TCHAR_DEFINED + /* Borland seems to forget to set this. */ + typedef _TCHAR TCHAR; +# define _TCHAR_DEFINED +#endif +#if defined(_MSC_VER) && defined(__STDC__) + /* VS2005 SP1 misses this. See [Bug #3110161] */ + typedef _TCHAR TCHAR; +#endif + +/* + *--------------------------------------------------------------------------- + * The following sets of #includes and #ifdefs are required to get Tcl to + * compile under the windows compilers. + *--------------------------------------------------------------------------- + */ + +#include <time.h> +#include <wchar.h> +#include <io.h> +#include <errno.h> +#include <fcntl.h> +#include <float.h> +#include <malloc.h> +#include <process.h> +#include <signal.h> +#include <limits.h> + +#ifndef __GNUC__ +# define strncasecmp _strnicmp +# define strcasecmp _stricmp +#endif + +/* + * Need to block out these includes for building extensions with MetroWerks + * compiler for Win32. + */ + +#ifndef __MWERKS__ +#include <sys/stat.h> +#include <sys/timeb.h> +# ifdef __BORLANDC__ +# include <utime.h> +# else +# include <sys/utime.h> +# endif /* __BORLANDC__ */ +#endif /* __MWERKS__ */ + +/* + * The following defines redefine the Windows Socket errors as + * BSD errors so Tcl_PosixError can do the right thing. + */ + +#ifndef ENOTEMPTY +# define ENOTEMPTY 41 /* Directory not empty */ +#endif +#ifndef EREMOTE +# define EREMOTE 66 /* The object is remote */ +#endif +#ifndef EPFNOSUPPORT +# define EPFNOSUPPORT 96 /* Protocol family not supported */ +#endif +#ifndef EADDRINUSE +# define EADDRINUSE 100 /* Address already in use */ +#endif +#ifndef EADDRNOTAVAIL +# define EADDRNOTAVAIL 101 /* Can't assign requested address */ +#endif +#ifndef EAFNOSUPPORT +# define EAFNOSUPPORT 102 /* Address family not supported */ +#endif +#ifndef EALREADY +# define EALREADY 103 /* Operation already in progress */ +#endif +#ifndef EBADMSG +# define EBADMSG 104 /* Not a data message */ +#endif +#ifndef ECANCELED +# define ECANCELED 105 /* Canceled */ +#endif +#ifndef ECONNABORTED +# define ECONNABORTED 106 /* Software caused connection abort */ +#endif +#ifndef ECONNREFUSED +# define ECONNREFUSED 107 /* Connection refused */ +#endif +#ifndef ECONNRESET +# define ECONNRESET 108 /* Connection reset by peer */ +#endif +#ifndef EDESTADDRREQ +# define EDESTADDRREQ 109 /* Destination address required */ +#endif +#ifndef EHOSTUNREACH +# define EHOSTUNREACH 110 /* No route to host */ +#endif +#ifndef EIDRM +# define EIDRM 111 /* Identifier removed */ +#endif +#ifndef EINPROGRESS +# define EINPROGRESS 112 /* Operation now in progress */ +#endif +#ifndef EISCONN +# define EISCONN 113 /* Socket is already connected */ +#endif +#ifndef ELOOP +# define ELOOP 114 /* Symbolic link loop */ +#endif +#ifndef EMSGSIZE +# define EMSGSIZE 115 /* Message too long */ +#endif +#ifndef ENETDOWN +# define ENETDOWN 116 /* Network is down */ +#endif +#ifndef ENETRESET +# define ENETRESET 117 /* Network dropped connection on reset */ +#endif +#ifndef ENETUNREACH +# define ENETUNREACH 118 /* Network is unreachable */ +#endif +#ifndef ENOBUFS +# define ENOBUFS 119 /* No buffer space available */ +#endif +#ifndef ENODATA +# define ENODATA 120 /* No data available */ +#endif +#ifndef ENOLINK +# define ENOLINK 121 /* Link has be severed */ +#endif +#ifndef ENOMSG +# define ENOMSG 122 /* No message of desired type */ +#endif +#ifndef ENOPROTOOPT +# define ENOPROTOOPT 123 /* Protocol not available */ +#endif +#ifndef ENOSR +# define ENOSR 124 /* Out of stream resources */ +#endif +#ifndef ENOSTR +# define ENOSTR 125 /* Not a stream device */ +#endif +#ifndef ENOTCONN +# define ENOTCONN 126 /* Socket is not connected */ +#endif +#ifndef ENOTRECOVERABLE +# define ENOTRECOVERABLE 127 /* Not recoverable */ +#endif +#ifndef ENOTSOCK +# define ENOTSOCK 128 /* Socket operation on non-socket */ +#endif +#ifndef ENOTSUP +# define ENOTSUP 129 /* Operation not supported */ +#endif +#ifndef EOPNOTSUPP +# define EOPNOTSUPP 130 /* Operation not supported on socket */ +#endif +#ifndef EOTHER +# define EOTHER 131 /* Other error */ +#endif +#ifndef EOVERFLOW +# define EOVERFLOW 132 /* File too big */ +#endif +#ifndef EOWNERDEAD +# define EOWNERDEAD 133 /* Owner dead */ +#endif +#ifndef EPROTO +# define EPROTO 134 /* Protocol error */ +#endif +#ifndef EPROTONOSUPPORT +# define EPROTONOSUPPORT 135 /* Protocol not supported */ +#endif +#ifndef EPROTOTYPE +# define EPROTOTYPE 136 /* Protocol wrong type for socket */ +#endif +#ifndef ETIME +# define ETIME 137 /* Timer expired */ +#endif +#ifndef ETIMEDOUT +# define ETIMEDOUT 138 /* Connection timed out */ +#endif +#ifndef ETXTBSY +# define ETXTBSY 139 /* Text file or pseudo-device busy */ +#endif +#ifndef EWOULDBLOCK +# define EWOULDBLOCK 140 /* Operation would block */ +#endif + + +/* 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 + * by Tcl_WaitPid() and generic/tclPosixStr.c + */ + +#ifndef SIGTRAP +# define SIGTRAP 5 +#endif +#ifndef SIGBUS +# define SIGBUS 10 +#endif + +/* + * Supply definitions for macros to query wait status, if not already + * defined in header files above. + */ + +#if TCL_UNION_WAIT +# define WAIT_STATUS_TYPE union wait +#else +# define WAIT_STATUS_TYPE int +#endif /* TCL_UNION_WAIT */ + +#ifndef WIFEXITED +# define WIFEXITED(stat) (((*((int *) &(stat))) & 0xC0000000) == 0) +#endif + +#ifndef WEXITSTATUS +# define WEXITSTATUS(stat) (*((int *) &(stat))) +#endif + +#ifndef WIFSIGNALED +# define WIFSIGNALED(stat) ((*((int *) &(stat))) & 0xC0000000) +#endif + +#ifndef WTERMSIG +# define WTERMSIG(stat) ((*((int *) &(stat))) & 0x7f) +#endif + +#ifndef WIFSTOPPED +# define WIFSTOPPED(stat) 0 +#endif + +#ifndef WSTOPSIG +# define WSTOPSIG(stat) (((*((int *) &(stat))) >> 8) & 0xff) +#endif + +/* + * Define constants for waitpid() system call if they aren't defined + * by a system header file. + */ + +#ifndef WNOHANG +# define WNOHANG 1 +#endif +#ifndef WUNTRACED +# define WUNTRACED 2 +#endif + +/* + * Define access mode constants if they aren't already defined. + */ + +#ifndef F_OK +# define F_OK 00 +#endif +#ifndef X_OK +# define X_OK 01 +#endif +#ifndef W_OK +# define W_OK 02 +#endif +#ifndef R_OK +# define R_OK 04 +#endif + +/* + * Define macros to query file type bits, if they're not already + * defined. + */ + +#ifndef S_IFLNK +# 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) +# else +# define S_ISREG(m) 0 +# endif +#endif /* !S_ISREG */ +#ifndef S_ISDIR +# ifdef S_IFDIR +# define S_ISDIR(m) (((m) & S_IFMT) == S_IFDIR) +# else +# define S_ISDIR(m) 0 +# endif +#endif /* !S_ISDIR */ +#ifndef S_ISCHR +# ifdef S_IFCHR +# define S_ISCHR(m) (((m) & S_IFMT) == S_IFCHR) +# else +# define S_ISCHR(m) 0 +# endif +#endif /* !S_ISCHR */ +#ifndef S_ISBLK +# ifdef S_IFBLK +# define S_ISBLK(m) (((m) & S_IFMT) == S_IFBLK) +# else +# define S_ISBLK(m) 0 +# endif +#endif /* !S_ISBLK */ +#ifndef S_ISFIFO +# ifdef S_IFIFO +# define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO) +# else +# define S_ISFIFO(m) 0 +# endif +#endif /* !S_ISFIFO */ +#ifndef S_ISLNK +# ifdef S_IFLNK +# define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK) +# else +# define S_ISLNK(m) 0 +# endif +#endif /* !S_ISLNK */ + + +/* + * Define MAXPATHLEN in terms of MAXPATH if available + */ + +#ifndef MAXPATH +# define MAXPATH MAX_PATH +#endif /* MAXPATH */ + +#ifndef MAXPATHLEN +# define MAXPATHLEN MAXPATH +#endif /* MAXPATHLEN */ + +/* + * Define pid_t and uid_t if they're not already defined. + */ + +#if ! TCL_PID_T +# define pid_t int +#endif /* !TCL_PID_T */ +#if ! TCL_UID_T +# define uid_t int +#endif /* !TCL_UID_T */ + +/* + * Visual C++ has some odd names for common functions, so we need to + * define a few macros to handle them. Also, it defines EDEADLOCK and + * EDEADLK as the same value, which confuses Tcl_ErrnoId(). + */ + +#if defined(_MSC_VER) || defined(__MSVCRT__) +# define environ _environ +# if defined(_MSC_VER) && (_MSC_VER < 1600) +# define hypot _hypot +# endif +# define exception _exception +# undef EDEADLOCK +# if defined(_MSC_VER) && (_MSC_VER >= 1700) +# define timezone _timezone +# endif +#endif /* _MSC_VER || __MSVCRT__ */ + +/* + * Borland's timezone and environ functions. + */ + +#ifdef __BORLANDC__ +# define timezone _timezone +# define environ _environ +#endif /* __BORLANDC__ */ + +#ifdef __WATCOMC__ +# if !defined(__CHAR_SIGNED__) +# error "You must use the -j switch to ensure char is signed." +# endif +#endif + + +/* + * MSVC 8.0 started to mark many standard C library functions depreciated + * including the *printf family and others. Tell it to shut up. + * (_MSC_VER is 1200 for VC6, 1300 or 1310 for vc7.net, 1400 for 8.0) + */ +#if defined(_MSC_VER) && (_MSC_VER >= 1400) +# pragma warning(disable:4244) +# pragma warning(disable:4267) +# pragma warning(disable:4996) +#endif + +/* + *--------------------------------------------------------------------------- + * The following macros and declarations represent the interface between + * generic and windows-specific parts of Tcl. Some of the macros may + * override functions declared in tclInt.h. + *--------------------------------------------------------------------------- + */ + +/* + * The default platform eol translation on Windows is TCL_TRANSLATE_CRLF: + */ + +#define TCL_PLATFORM_TRANSLATION TCL_TRANSLATE_CRLF + +/* + * Declare dynamic loading extension macro. + */ + +#define TCL_SHLIB_EXT ".dll" + +/* + * The following define ensures that we use the native putenv + * implementation to modify the environment array. This keeps + * the C level environment in synch with the system level environment. + */ + +#define USE_PUTENV 1 +#define USE_PUTENV_FOR_UNSET 1 + +/* + * Msvcrt's putenv() copies the string rather than takes ownership of it. + */ + +#if defined(_MSC_VER) || defined(__MSVCRT__) +# define HAVE_PUTENV_THAT_COPIES 1 +#endif + +/* + * Older version of Mingw are known to lack a MWMO_ALERTABLE define. + */ +#if !defined(MWMO_ALERTABLE) +# define MWMO_ALERTABLE 2 +#endif + +/* + * The following defines wrap the system memory allocation routines for + * use by tclAlloc.c. + */ + +#define TclpSysAlloc(size, isBin) ((void*)HeapAlloc(GetProcessHeap(), \ + (DWORD)0, (DWORD)size)) +#define TclpSysFree(ptr) (HeapFree(GetProcessHeap(), \ + (DWORD)0, (HGLOBAL)ptr)) +#define TclpSysRealloc(ptr, size) ((void*)HeapReAlloc(GetProcessHeap(), \ + (DWORD)0, (LPVOID)ptr, (DWORD)size)) + +/* This type is not defined in the Windows headers */ +#define socklen_t int + + +/* + * The following macros have trivial definitions, allowing generic code to + * address platform-specific issues. + */ + +#define TclpReleaseFile(file) ckfree(file) + +/* + * The following macros and declarations wrap the C runtime library + * functions. + */ + +#define TclpExit exit + +#ifndef INVALID_SET_FILE_POINTER +#define INVALID_SET_FILE_POINTER 0xFFFFFFFF +#endif /* INVALID_SET_FILE_POINTER */ + +#ifndef LABEL_SECURITY_INFORMATION +# define LABEL_SECURITY_INFORMATION (0x00000010L) +#endif + +#endif /* _TCLWINPORT */ diff --git a/win/tclWinReg.c b/win/tclWinReg.c new file mode 100644 index 0000000..de48b9b --- /dev/null +++ b/win/tclWinReg.c @@ -0,0 +1,1545 @@ +/* + * tclWinReg.c -- + * + * This file contains the implementation of the "registry" Tcl built-in + * command. This command is built as a dynamically loadable extension in + * a separate DLL. + * + * Copyright (c) 1997 by Sun Microsystems, Inc. + * Copyright (c) 1998-1999 by Scriptics Corporation. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#undef STATIC_BUILD +#ifndef USE_TCL_STUBS +# define USE_TCL_STUBS +#endif +#include "tclInt.h" +#ifdef _MSC_VER +# pragma comment (lib, "advapi32.lib") +#endif +#include <stdlib.h> + +#ifndef UNICODE +# undef Tcl_WinTCharToUtf +# define Tcl_WinTCharToUtf(a,b,c) Tcl_ExternalToUtfDString(NULL,a,b,c) +# undef Tcl_WinUtfToTChar +# define Tcl_WinUtfToTChar(a,b,c) Tcl_UtfToExternalDString(NULL,a,b,c) +#endif /* !UNICODE */ + +/* + * Ensure that we can say which registry is being accessed. + */ + +#ifndef KEY_WOW64_64KEY +# define KEY_WOW64_64KEY (0x0100) +#endif +#ifndef KEY_WOW64_32KEY +# define KEY_WOW64_32KEY (0x0200) +#endif + +/* + * The maximum length of a sub-key name. + */ + +#ifndef MAX_KEY_LENGTH +# define MAX_KEY_LENGTH 256 +#endif + +/* + * The following macros convert between different endian ints. + */ + +#define SWAPWORD(x) MAKEWORD(HIBYTE(x), LOBYTE(x)) +#define SWAPLONG(x) MAKELONG(SWAPWORD(HIWORD(x)), SWAPWORD(LOWORD(x))) + +/* + * The following flag is used in OpenKeys to indicate that the specified key + * should be created if it doesn't currently exist. + */ + +#define REG_CREATE 1 + +/* + * The following tables contain the mapping from registry root names to the + * system predefined keys. + */ + +static const char *const rootKeyNames[] = { + "HKEY_LOCAL_MACHINE", "HKEY_USERS", "HKEY_CLASSES_ROOT", + "HKEY_CURRENT_USER", "HKEY_CURRENT_CONFIG", + "HKEY_PERFORMANCE_DATA", "HKEY_DYN_DATA", NULL +}; + +static const HKEY rootKeys[] = { + HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER, + HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, HKEY_DYN_DATA +}; + +static const char REGISTRY_ASSOC_KEY[] = "registry::command"; + +/* + * The following table maps from registry types to strings. Note that the + * indices for this array are the same as the constants for the known registry + * types so we don't need a separate table to hold the mapping. + */ + +static const char *const typeNames[] = { + "none", "sz", "expand_sz", "binary", "dword", + "dword_big_endian", "link", "multi_sz", "resource_list", NULL +}; + +static DWORD lastType = REG_RESOURCE_LIST; + +/* + * Declarations for functions defined in this file. + */ + +static void AppendSystemError(Tcl_Interp *interp, DWORD error); +static int BroadcastValue(Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static DWORD ConvertDWORD(DWORD type, DWORD value); +static void DeleteCmd(ClientData clientData); +static int DeleteKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj, + REGSAM mode); +static int DeleteValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, + Tcl_Obj *valueNameObj, REGSAM mode); +static int GetKeyNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj, + Tcl_Obj *patternObj, REGSAM mode); +static int GetType(Tcl_Interp *interp, Tcl_Obj *keyNameObj, + Tcl_Obj *valueNameObj, REGSAM mode); +static int GetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, + Tcl_Obj *valueNameObj, REGSAM mode); +static int GetValueNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj, + Tcl_Obj *patternObj, REGSAM mode); +static int OpenKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj, + REGSAM mode, int flags, HKEY *keyPtr); +static DWORD OpenSubKey(char *hostName, HKEY rootKey, + char *keyName, REGSAM mode, int flags, + HKEY *keyPtr); +static int ParseKeyName(Tcl_Interp *interp, char *name, + char **hostNamePtr, HKEY *rootKeyPtr, + char **keyNamePtr); +static DWORD RecursiveDeleteKey(HKEY hStartKey, + const TCHAR * pKeyName, REGSAM mode); +static int RegistryObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int SetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, + Tcl_Obj *valueNameObj, Tcl_Obj *dataObj, + Tcl_Obj *typeObj, REGSAM mode); + +DLLEXPORT int Registry_Init(Tcl_Interp *interp); +DLLEXPORT int Registry_Unload(Tcl_Interp *interp, int flags); + +/* + *---------------------------------------------------------------------- + * + * Registry_Init -- + * + * This function initializes the registry command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Registry_Init( + Tcl_Interp *interp) +{ + Tcl_Command cmd; + + if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { + return TCL_ERROR; + } + + cmd = Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd, + interp, DeleteCmd); + Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, cmd); + return Tcl_PkgProvide(interp, "registry", "1.3.2"); +} + +/* + *---------------------------------------------------------------------- + * + * Registry_Unload -- + * + * This function removes the registry command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * The registry command is deleted and the dll may be unloaded. + * + *---------------------------------------------------------------------- + */ + +int +Registry_Unload( + Tcl_Interp *interp, /* Interpreter for unloading */ + int flags) /* Flags passed by the unload system */ +{ + Tcl_Command cmd; + Tcl_Obj *objv[3]; + + /* + * Unregister the registry package. There is no Tcl_PkgForget() + */ + + objv[0] = Tcl_NewStringObj("package", -1); + objv[1] = Tcl_NewStringObj("forget", -1); + objv[2] = Tcl_NewStringObj("registry", -1); + Tcl_EvalObjv(interp, 3, objv, TCL_EVAL_GLOBAL); + + /* + * Delete the originally registered command. + */ + + cmd = Tcl_GetAssocData(interp, REGISTRY_ASSOC_KEY, NULL); + if (cmd != NULL) { + Tcl_DeleteCommandFromToken(interp, cmd); + } + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteCmd -- + * + * Cleanup the interp command token so that unloading doesn't try to + * re-delete the command (which will crash). + * + * Results: + * None. + * + * Side effects: + * The unload command will not attempt to delete this command. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteCmd( + ClientData clientData) +{ + Tcl_Interp *interp = clientData; + + Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, NULL); +} + +/* + *---------------------------------------------------------------------- + * + * RegistryObjCmd -- + * + * This function implements the Tcl "registry" command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +RegistryObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument values. */ +{ + int n = 1; + int index, argc; + REGSAM mode = 0; + const char *errString = NULL; + + static const char *const subcommands[] = { + "broadcast", "delete", "get", "keys", "set", "type", "values", NULL + }; + enum SubCmdIdx { + BroadcastIdx, DeleteIdx, GetIdx, KeysIdx, SetIdx, TypeIdx, ValuesIdx + }; + static const char *const modes[] = { + "-32bit", "-64bit", NULL + }; + + if (objc < 2) { + wrongArgs: + Tcl_WrongNumArgs(interp, 1, objv, "?-32bit|-64bit? option ?arg ...?"); + return TCL_ERROR; + } + + if (Tcl_GetString(objv[n])[0] == '-') { + if (Tcl_GetIndexFromObj(interp, objv[n++], modes, "mode", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + switch (index) { + case 0: /* -32bit */ + mode |= KEY_WOW64_32KEY; + break; + case 1: /* -64bit */ + mode |= KEY_WOW64_64KEY; + break; + } + if (objc < 3) { + goto wrongArgs; + } + } + + if (Tcl_GetIndexFromObj(interp, objv[n++], subcommands, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + + argc = (objc - n); + switch (index) { + case BroadcastIdx: /* broadcast */ + if (argc == 1 || argc == 3) { + int res = BroadcastValue(interp, argc, objv + n); + + if (res != TCL_BREAK) { + return res; + } + } + errString = "keyName ?-timeout milliseconds?"; + break; + case DeleteIdx: /* delete */ + if (argc == 1) { + return DeleteKey(interp, objv[n], mode); + } else if (argc == 2) { + return DeleteValue(interp, objv[n], objv[n+1], mode); + } + errString = "keyName ?valueName?"; + break; + case GetIdx: /* get */ + if (argc == 2) { + return GetValue(interp, objv[n], objv[n+1], mode); + } + errString = "keyName valueName"; + break; + case KeysIdx: /* keys */ + if (argc == 1) { + return GetKeyNames(interp, objv[n], NULL, mode); + } else if (argc == 2) { + return GetKeyNames(interp, objv[n], objv[n+1], mode); + } + errString = "keyName ?pattern?"; + break; + case SetIdx: /* set */ + if (argc == 1) { + HKEY key; + + /* + * Create the key and then close it immediately. + */ + + mode |= KEY_ALL_ACCESS; + if (OpenKey(interp, objv[n], mode, 1, &key) != TCL_OK) { + return TCL_ERROR; + } + RegCloseKey(key); + return TCL_OK; + } else if (argc == 3) { + return SetValue(interp, objv[n], objv[n+1], objv[n+2], NULL, + mode); + } else if (argc == 4) { + return SetValue(interp, objv[n], objv[n+1], objv[n+2], objv[n+3], + mode); + } + errString = "keyName ?valueName data ?type??"; + break; + case TypeIdx: /* type */ + if (argc == 2) { + return GetType(interp, objv[n], objv[n+1], mode); + } + errString = "keyName valueName"; + break; + case ValuesIdx: /* values */ + if (argc == 1) { + return GetValueNames(interp, objv[n], NULL, mode); + } else if (argc == 2) { + return GetValueNames(interp, objv[n], objv[n+1], mode); + } + errString = "keyName ?pattern?"; + break; + } + Tcl_WrongNumArgs(interp, (mode ? 3 : 2), objv, errString); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteKey -- + * + * This function deletes a registry key. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +DeleteKey( + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Obj *keyNameObj, /* Name of key to delete. */ + REGSAM mode) /* Mode flags to pass. */ +{ + char *tail, *buffer, *hostName, *keyName; + const TCHAR *nativeTail; + HKEY rootKey, subkey; + DWORD result; + Tcl_DString buf; + REGSAM saveMode = mode; + + /* + * Find the parent of the key being deleted and open it. + */ + + keyName = Tcl_GetString(keyNameObj); + buffer = ckalloc(keyNameObj->length + 1); + strcpy(buffer, keyName); + + if (ParseKeyName(interp, buffer, &hostName, &rootKey, + &keyName) != TCL_OK) { + ckfree(buffer); + return TCL_ERROR; + } + + if (*keyName == '\0') { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("bad key: cannot delete root keys", -1)); + Tcl_SetErrorCode(interp, "WIN_REG", "DEL_ROOT_KEY", NULL); + ckfree(buffer); + return TCL_ERROR; + } + + tail = strrchr(keyName, '\\'); + if (tail) { + *tail++ = '\0'; + } else { + tail = keyName; + keyName = NULL; + } + + mode |= KEY_ENUMERATE_SUB_KEYS | DELETE; + result = OpenSubKey(hostName, rootKey, keyName, mode, 0, &subkey); + if (result != ERROR_SUCCESS) { + ckfree(buffer); + if (result == ERROR_FILE_NOT_FOUND) { + return TCL_OK; + } + Tcl_SetObjResult(interp, + Tcl_NewStringObj("unable to delete key: ", -1)); + AppendSystemError(interp, result); + return TCL_ERROR; + } + + /* + * Now we recursively delete the key and everything below it. + */ + + nativeTail = Tcl_WinUtfToTChar(tail, -1, &buf); + result = RecursiveDeleteKey(subkey, nativeTail, saveMode); + Tcl_DStringFree(&buf); + + if (result != ERROR_SUCCESS && result != ERROR_FILE_NOT_FOUND) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("unable to delete key: ", -1)); + AppendSystemError(interp, result); + result = TCL_ERROR; + } else { + result = TCL_OK; + } + + RegCloseKey(subkey); + ckfree(buffer); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteValue -- + * + * This function deletes a value from a registry key. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +DeleteValue( + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Obj *keyNameObj, /* Name of key. */ + Tcl_Obj *valueNameObj, /* Name of value to delete. */ + REGSAM mode) /* Mode flags to pass. */ +{ + HKEY key; + char *valueName; + size_t length; + DWORD result; + Tcl_DString ds; + + /* + * Attempt to open the key for deletion. + */ + + mode |= KEY_SET_VALUE; + if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) { + return TCL_ERROR; + } + + valueName = Tcl_GetString(valueNameObj); + length = valueNameObj->length; + Tcl_WinUtfToTChar(valueName, length, &ds); + result = RegDeleteValue(key, (const TCHAR *)Tcl_DStringValue(&ds)); + Tcl_DStringFree(&ds); + if (result != ERROR_SUCCESS) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unable to delete value \"%s\" from key \"%s\": ", + Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj))); + AppendSystemError(interp, result); + result = TCL_ERROR; + } else { + result = TCL_OK; + } + RegCloseKey(key); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * GetKeyNames -- + * + * This function enumerates the subkeys of a given key. If the optional + * pattern is supplied, then only keys that match the pattern will be + * returned. + * + * Results: + * Returns the list of subkeys in the result object of the interpreter, + * or an error message on failure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +GetKeyNames( + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Obj *keyNameObj, /* Key to enumerate. */ + Tcl_Obj *patternObj, /* Optional match pattern. */ + REGSAM mode) /* Mode flags to pass. */ +{ + const char *pattern; /* Pattern being matched against subkeys */ + HKEY key; /* Handle to the key being examined */ + TCHAR buffer[MAX_KEY_LENGTH]; + /* Buffer to hold the subkey name */ + DWORD bufSize; /* Size of the buffer */ + DWORD index; /* Position of the current subkey */ + char *name; /* Subkey name */ + Tcl_Obj *resultPtr; /* List of subkeys being accumulated */ + int result = TCL_OK; /* Return value from this command */ + Tcl_DString ds; /* Buffer to translate subkey name to UTF-8 */ + + if (patternObj) { + pattern = Tcl_GetString(patternObj); + } else { + pattern = NULL; + } + + /* + * Attempt to open the key for enumeration. + */ + + mode |= KEY_QUERY_VALUE | KEY_ENUMERATE_SUB_KEYS; + if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Enumerate the subkeys. + */ + + resultPtr = Tcl_NewObj(); + for (index = 0;; ++index) { + bufSize = MAX_KEY_LENGTH; + result = RegEnumKeyEx(key, index, buffer, &bufSize, + NULL, NULL, NULL, NULL); + if (result != ERROR_SUCCESS) { + if (result == ERROR_NO_MORE_ITEMS) { + result = TCL_OK; + } else { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unable to enumerate subkeys of \"%s\": ", + Tcl_GetString(keyNameObj))); + AppendSystemError(interp, result); + result = TCL_ERROR; + } + break; + } + Tcl_WinTCharToUtf(buffer, bufSize * sizeof(TCHAR), &ds); + name = Tcl_DStringValue(&ds); + if (pattern && !Tcl_StringMatch(name, pattern)) { + Tcl_DStringFree(&ds); + continue; + } + result = Tcl_ListObjAppendElement(interp, resultPtr, + Tcl_NewStringObj(name, Tcl_DStringLength(&ds))); + Tcl_DStringFree(&ds); + if (result != TCL_OK) { + break; + } + } + if (result == TCL_OK) { + Tcl_SetObjResult(interp, resultPtr); + } else { + Tcl_DecrRefCount(resultPtr); /* BUGFIX: Don't leak on failure. */ + } + + RegCloseKey(key); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * GetType -- + * + * This function gets the type of a given registry value and places it in + * the interpreter result. + * + * Results: + * Returns a normal Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +GetType( + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Obj *keyNameObj, /* Name of key. */ + Tcl_Obj *valueNameObj, /* Name of value to get. */ + REGSAM mode) /* Mode flags to pass. */ +{ + HKEY key; + DWORD result, type; + Tcl_DString ds; + const char *valueName; + const TCHAR *nativeValue; + size_t length; + + /* + * Attempt to open the key for reading. + */ + + mode |= KEY_QUERY_VALUE; + if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Get the type of the value. + */ + + valueName = Tcl_GetString(valueNameObj); + length = valueNameObj->length; + nativeValue = Tcl_WinUtfToTChar(valueName, length, &ds); + result = RegQueryValueEx(key, nativeValue, NULL, &type, + NULL, NULL); + Tcl_DStringFree(&ds); + RegCloseKey(key); + + if (result != ERROR_SUCCESS) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unable to get type of value \"%s\" from key \"%s\": ", + Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj))); + AppendSystemError(interp, result); + return TCL_ERROR; + } + + /* + * Set the type into the result. Watch out for unknown types. If we don't + * know about the type, just use the numeric value. + */ + + if (type > lastType) { + Tcl_SetObjResult(interp, Tcl_NewIntObj((int) type)); + } else { + Tcl_SetObjResult(interp, Tcl_NewStringObj(typeNames[type], -1)); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * GetValue -- + * + * This function gets the contents of a registry value and places a list + * containing the data and the type in the interpreter result. + * + * Results: + * Returns a normal Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +GetValue( + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Obj *keyNameObj, /* Name of key. */ + Tcl_Obj *valueNameObj, /* Name of value to get. */ + REGSAM mode) /* Mode flags to pass. */ +{ + HKEY key; + const char *valueName; + const TCHAR *nativeValue; + DWORD result, length, type; + Tcl_DString data, buf; + size_t nameLen; + + /* + * Attempt to open the key for reading. + */ + + mode |= KEY_QUERY_VALUE; + if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Initialize a Dstring to maximum statically allocated size we could get + * one more byte by avoiding Tcl_DStringSetLength() and just setting + * length to TCL_DSTRING_STATIC_SIZE, but this should be safer if the + * implementation of Dstrings changes. + * + * This allows short values to be read from the registy in one call. + * Longer values need a second call with an expanded DString. + */ + + Tcl_DStringInit(&data); + Tcl_DStringSetLength(&data, TCL_DSTRING_STATIC_SIZE - 1); + length = TCL_DSTRING_STATIC_SIZE/sizeof(TCHAR) - 1; + + valueName = Tcl_GetString(valueNameObj); + nameLen = valueNameObj->length; + nativeValue = Tcl_WinUtfToTChar(valueName, nameLen, &buf); + + result = RegQueryValueEx(key, nativeValue, NULL, &type, + (BYTE *) Tcl_DStringValue(&data), &length); + while (result == ERROR_MORE_DATA) { + /* + * The Windows docs say that in this error case, we just need to + * expand our buffer and request more data. Required for + * HKEY_PERFORMANCE_DATA + */ + + length = Tcl_DStringLength(&data) * (2 / sizeof(TCHAR)); + Tcl_DStringSetLength(&data, (int) length * sizeof(TCHAR)); + result = RegQueryValueEx(key, nativeValue, + NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length); + } + Tcl_DStringFree(&buf); + RegCloseKey(key); + if (result != ERROR_SUCCESS) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unable to get value \"%s\" from key \"%s\": ", + Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj))); + AppendSystemError(interp, result); + Tcl_DStringFree(&data); + return TCL_ERROR; + } + + /* + * If the data is a 32-bit quantity, store it as an integer object. If it + * is a multi-string, store it as a list of strings. For null-terminated + * strings, append up the to first null. Otherwise, store it as a binary + * string. + */ + + if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) { + Tcl_SetObjResult(interp, Tcl_NewIntObj((int) ConvertDWORD(type, + *((DWORD *) Tcl_DStringValue(&data))))); + } else if (type == REG_MULTI_SZ) { + char *p = Tcl_DStringValue(&data); + char *end = Tcl_DStringValue(&data) + length; + Tcl_Obj *resultPtr = Tcl_NewObj(); + + /* + * Multistrings are stored as an array of null-terminated strings, + * terminated by two null characters. Also do a bounds check in case + * we get bogus data. + */ + + while ((p < end) && *((WCHAR *) p) != 0) { + WCHAR *wp; + + Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf); + Tcl_ListObjAppendElement(interp, resultPtr, + Tcl_NewStringObj(Tcl_DStringValue(&buf), + Tcl_DStringLength(&buf))); + wp = (WCHAR *) p; + + while (*wp++ != 0) {/* empty body */} + p = (char *) wp; + Tcl_DStringFree(&buf); + } + Tcl_SetObjResult(interp, resultPtr); + } else if ((type == REG_SZ) || (type == REG_EXPAND_SZ)) { + Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&data), -1, &buf); + Tcl_DStringResult(interp, &buf); + } else { + /* + * Save binary data as a byte array. + */ + + Tcl_SetObjResult(interp, Tcl_NewByteArrayObj( + (BYTE *) Tcl_DStringValue(&data), (int) length)); + } + Tcl_DStringFree(&data); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * GetValueNames -- + * + * This function enumerates the values of the a given key. If the + * optional pattern is supplied, then only value names that match the + * pattern will be returned. + * + * Results: + * Returns the list of value names in the result object of the + * interpreter, or an error message on failure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +GetValueNames( + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Obj *keyNameObj, /* Key to enumerate. */ + Tcl_Obj *patternObj, /* Optional match pattern. */ + REGSAM mode) /* Mode flags to pass. */ +{ + HKEY key; + Tcl_Obj *resultPtr; + DWORD index, size, result; + Tcl_DString buffer, ds; + const char *pattern, *name; + + /* + * Attempt to open the key for enumeration. + */ + + mode |= KEY_QUERY_VALUE; + if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) { + return TCL_ERROR; + } + + resultPtr = Tcl_NewObj(); + Tcl_DStringInit(&buffer); + Tcl_DStringSetLength(&buffer, (int) (MAX_KEY_LENGTH * sizeof(TCHAR))); + index = 0; + result = TCL_OK; + + if (patternObj) { + pattern = Tcl_GetString(patternObj); + } else { + pattern = NULL; + } + + /* + * Enumerate the values under the given subkey until we get an error, + * indicating the end of the list. Note that we need to reset size after + * each iteration because RegEnumValue smashes the old value. + */ + + size = MAX_KEY_LENGTH; + while (RegEnumValue(key,index, (TCHAR *)Tcl_DStringValue(&buffer), + &size, NULL, NULL, NULL, NULL) == ERROR_SUCCESS) { + size *= sizeof(TCHAR); + + Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&buffer), (int) size, + &ds); + name = Tcl_DStringValue(&ds); + if (!pattern || Tcl_StringMatch(name, pattern)) { + result = Tcl_ListObjAppendElement(interp, resultPtr, + Tcl_NewStringObj(name, Tcl_DStringLength(&ds))); + if (result != TCL_OK) { + Tcl_DStringFree(&ds); + break; + } + } + Tcl_DStringFree(&ds); + + index++; + size = MAX_KEY_LENGTH; + } + Tcl_SetObjResult(interp, resultPtr); + Tcl_DStringFree(&buffer); + RegCloseKey(key); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * OpenKey -- + * + * This function opens the specified key. This function is a simple + * wrapper around ParseKeyName and OpenSubKey. + * + * Results: + * Returns the opened key in the keyPtr argument and a Tcl result code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +OpenKey( + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Obj *keyNameObj, /* Key to open. */ + REGSAM mode, /* Access mode. */ + int flags, /* 0 or REG_CREATE. */ + HKEY *keyPtr) /* Returned HKEY. */ +{ + char *keyName, *buffer, *hostName; + size_t length; + HKEY rootKey; + DWORD result; + + keyName = Tcl_GetString(keyNameObj); + length = keyNameObj->length; + buffer = ckalloc(length + 1); + strcpy(buffer, keyName); + + result = ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName); + if (result == TCL_OK) { + result = OpenSubKey(hostName, rootKey, keyName, mode, flags, keyPtr); + if (result != ERROR_SUCCESS) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("unable to open key: ", -1)); + AppendSystemError(interp, result); + result = TCL_ERROR; + } else { + result = TCL_OK; + } + } + + ckfree(buffer); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * OpenSubKey -- + * + * This function opens a given subkey of a root key on the specified + * host. + * + * Results: + * Returns the opened key in the keyPtr and a Windows error code as the + * return value. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static DWORD +OpenSubKey( + char *hostName, /* Host to access, or NULL for local. */ + HKEY rootKey, /* Root registry key. */ + char *keyName, /* Subkey name. */ + REGSAM mode, /* Access mode. */ + int flags, /* 0 or REG_CREATE. */ + HKEY *keyPtr) /* Returned HKEY. */ +{ + DWORD result; + Tcl_DString buf; + + /* + * Attempt to open the root key on a remote host if necessary. + */ + + if (hostName) { + hostName = (char *) Tcl_WinUtfToTChar(hostName, -1, &buf); + result = RegConnectRegistry((TCHAR *)hostName, rootKey, + &rootKey); + Tcl_DStringFree(&buf); + if (result != ERROR_SUCCESS) { + return result; + } + } + + /* + * Now open the specified key with the requested permissions. Note that + * this key must be closed by the caller. + */ + + keyName = (char *) Tcl_WinUtfToTChar(keyName, -1, &buf); + if (flags & REG_CREATE) { + DWORD create; + + result = RegCreateKeyEx(rootKey, (TCHAR *)keyName, 0, NULL, + REG_OPTION_NON_VOLATILE, mode, NULL, keyPtr, &create); + } else if (rootKey == HKEY_PERFORMANCE_DATA) { + /* + * Here we fudge it for this special root key. See MSDN for more info + * on HKEY_PERFORMANCE_DATA and the peculiarities surrounding it. + */ + + *keyPtr = HKEY_PERFORMANCE_DATA; + result = ERROR_SUCCESS; + } else { + result = RegOpenKeyEx(rootKey, (TCHAR *)keyName, 0, mode, + keyPtr); + } + Tcl_DStringFree(&buf); + + /* + * Be sure to close the root key since we are done with it now. + */ + + if (hostName) { + RegCloseKey(rootKey); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * ParseKeyName -- + * + * This function parses a key name into the host, root, and subkey parts. + * + * Results: + * The pointers to the start of the host and subkey names are returned in + * the hostNamePtr and keyNamePtr variables. The specified root HKEY is + * returned in rootKeyPtr. Returns a standard Tcl result. + * + * Side effects: + * Modifies the name string by inserting nulls. + * + *---------------------------------------------------------------------- + */ + +static int +ParseKeyName( + Tcl_Interp *interp, /* Current interpreter. */ + char *name, + char **hostNamePtr, + HKEY *rootKeyPtr, + char **keyNamePtr) +{ + char *rootName; + int result, index; + Tcl_Obj *rootObj; + + /* + * Split the key into host and root portions. + */ + + *hostNamePtr = *keyNamePtr = rootName = NULL; + if (name[0] == '\\') { + if (name[1] == '\\') { + *hostNamePtr = name; + for (rootName = name+2; *rootName != '\0'; rootName++) { + if (*rootName == '\\') { + *rootName++ = '\0'; + break; + } + } + } + } else { + rootName = name; + } + if (!rootName) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad key \"%s\": must start with a valid root", name)); + Tcl_SetErrorCode(interp, "WIN_REG", "NO_ROOT_KEY", NULL); + return TCL_ERROR; + } + + /* + * Split the root into root and subkey portions. + */ + + for (*keyNamePtr = rootName; **keyNamePtr != '\0'; (*keyNamePtr)++) { + if (**keyNamePtr == '\\') { + **keyNamePtr = '\0'; + (*keyNamePtr)++; + break; + } + } + + /* + * Look for a matching root name. + */ + + rootObj = Tcl_NewStringObj(rootName, -1); + result = Tcl_GetIndexFromObj(interp, rootObj, rootKeyNames, "root name", + TCL_EXACT, &index); + Tcl_DecrRefCount(rootObj); + if (result != TCL_OK) { + return TCL_ERROR; + } + *rootKeyPtr = rootKeys[index]; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * RecursiveDeleteKey -- + * + * This function recursively deletes all the keys below a starting key. + * Although Windows 95 does this automatically, we still need to do this + * for Windows NT. + * + * Results: + * Returns a Windows error code. + * + * Side effects: + * Deletes all of the keys and values below the given key. + * + *---------------------------------------------------------------------- + */ + +static DWORD +RecursiveDeleteKey( + HKEY startKey, /* Parent of key to be deleted. */ + const TCHAR *keyName, /* Name of key to be deleted in external + * encoding, not UTF. */ + REGSAM mode) /* Mode flags to pass. */ +{ + DWORD result, size; + Tcl_DString subkey; + HKEY hKey; + REGSAM saveMode = mode; + static int checkExProc = 0; + static FARPROC regDeleteKeyExProc = NULL; + + /* + * Do not allow NULL or empty key name. + */ + + if (!keyName || *keyName == '\0') { + return ERROR_BADKEY; + } + + mode |= KEY_ENUMERATE_SUB_KEYS | DELETE | KEY_QUERY_VALUE; + result = RegOpenKeyEx(startKey, keyName, 0, mode, &hKey); + if (result != ERROR_SUCCESS) { + return result; + } + + Tcl_DStringInit(&subkey); + Tcl_DStringSetLength(&subkey, (int) (MAX_KEY_LENGTH * sizeof(TCHAR))); + + mode = saveMode; + while (result == ERROR_SUCCESS) { + /* + * Always get index 0 because key deletion changes ordering. + */ + + size = MAX_KEY_LENGTH; + result = RegEnumKeyEx(hKey, 0, (TCHAR *)Tcl_DStringValue(&subkey), + &size, NULL, NULL, NULL, NULL); + if (result == ERROR_NO_MORE_ITEMS) { + /* + * RegDeleteKeyEx doesn't exist on non-64bit XP platforms, so we + * can't compile with it in. We need to check for it at runtime + * and use it if we find it. + */ + + if (mode && !checkExProc) { + HMODULE handle; + + checkExProc = 1; + handle = GetModuleHandle(TEXT("ADVAPI32")); + regDeleteKeyExProc = (FARPROC) + GetProcAddress(handle, "RegDeleteKeyExW"); + } + if (mode && regDeleteKeyExProc) { + result = regDeleteKeyExProc(startKey, keyName, mode, 0); + } else { + result = RegDeleteKey(startKey, keyName); + } + break; + } else if (result == ERROR_SUCCESS) { + result = RecursiveDeleteKey(hKey, + (const TCHAR *) Tcl_DStringValue(&subkey), mode); + } + } + Tcl_DStringFree(&subkey); + RegCloseKey(hKey); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * SetValue -- + * + * This function sets the contents of a registry value. If the key or + * value does not exist, it will be created. If it does exist, then the + * data and type will be replaced. + * + * Results: + * Returns a normal Tcl result. + * + * Side effects: + * May create new keys or values. + * + *---------------------------------------------------------------------- + */ + +static int +SetValue( + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Obj *keyNameObj, /* Name of key. */ + Tcl_Obj *valueNameObj, /* Name of value to set. */ + Tcl_Obj *dataObj, /* Data to be written. */ + Tcl_Obj *typeObj, /* Type of data to be written. */ + REGSAM mode) /* Mode flags to pass. */ +{ + int type; + size_t length; + DWORD result; + HKEY key; + const char *valueName; + Tcl_DString nameBuf; + + if (typeObj == NULL) { + type = REG_SZ; + } else if (Tcl_GetIndexFromObj(interp, typeObj, typeNames, "type", + 0, (int *) &type) != TCL_OK) { + if (Tcl_GetIntFromObj(NULL, typeObj, (int *) &type) != TCL_OK) { + return TCL_ERROR; + } + Tcl_ResetResult(interp); + } + mode |= KEY_ALL_ACCESS; + if (OpenKey(interp, keyNameObj, mode, 1, &key) != TCL_OK) { + return TCL_ERROR; + } + + valueName = Tcl_GetString(valueNameObj); + length = valueNameObj->length; + valueName = (char *) Tcl_WinUtfToTChar(valueName, length, &nameBuf); + + if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) { + int value; + + if (Tcl_GetIntFromObj(interp, dataObj, &value) != TCL_OK) { + RegCloseKey(key); + Tcl_DStringFree(&nameBuf); + return TCL_ERROR; + } + + value = ConvertDWORD((DWORD) type, (DWORD) value); + result = RegSetValueEx(key, (TCHAR *) valueName, 0, + (DWORD) type, (BYTE *) &value, sizeof(DWORD)); + } else if (type == REG_MULTI_SZ) { + Tcl_DString data, buf; + int objc, i; + Tcl_Obj **objv; + + if (Tcl_ListObjGetElements(interp, dataObj, &objc, &objv) != TCL_OK) { + RegCloseKey(key); + Tcl_DStringFree(&nameBuf); + return TCL_ERROR; + } + + /* + * Append the elements as null terminated strings. Note that we must + * not assume the length of the string in case there are embedded + * nulls, which aren't allowed in REG_MULTI_SZ values. + */ + + Tcl_DStringInit(&data); + for (i = 0; i < objc; i++) { + const char *bytes = Tcl_GetString(objv[i]); + + length = objv[i]->length; + Tcl_DStringAppend(&data, bytes, length); + + /* + * Add a null character to separate this value from the next. + */ + + Tcl_DStringAppend(&data, "", 1); /* NUL-terminated string */ + } + + Tcl_WinUtfToTChar(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1, + &buf); + result = RegSetValueEx(key, (TCHAR *) valueName, 0, + (DWORD) type, (BYTE *) Tcl_DStringValue(&buf), + (DWORD) Tcl_DStringLength(&buf)); + Tcl_DStringFree(&data); + Tcl_DStringFree(&buf); + } else if (type == REG_SZ || type == REG_EXPAND_SZ) { + Tcl_DString buf; + const char *data = Tcl_GetString(dataObj); + + length = dataObj->length; + data = (char *) Tcl_WinUtfToTChar(data, length, &buf); + + /* + * Include the null in the length, padding if needed for WCHAR. + */ + + Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1); + length = Tcl_DStringLength(&buf) + 1; + + result = RegSetValueEx(key, (TCHAR *) valueName, 0, + (DWORD) type, (BYTE *) data, (DWORD) length); + Tcl_DStringFree(&buf); + } else { + BYTE *data; + int bytelength; + + /* + * Store binary data in the registry. + */ + + data = (BYTE *) Tcl_GetByteArrayFromObj(dataObj, &bytelength); + result = RegSetValueEx(key, (TCHAR *) valueName, 0, + (DWORD) type, data, (DWORD) bytelength); + } + + Tcl_DStringFree(&nameBuf); + RegCloseKey(key); + + if (result != ERROR_SUCCESS) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("unable to set value: ", -1)); + AppendSystemError(interp, result); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * BroadcastValue -- + * + * This function broadcasts a WM_SETTINGCHANGE message to indicate to + * other programs that we have changed the contents of a registry value. + * + * Results: + * Returns a normal Tcl result. + * + * Side effects: + * Will cause other programs to reload their system settings. + * + *---------------------------------------------------------------------- + */ + +static int +BroadcastValue( + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument values. */ +{ + LRESULT result; + DWORD_PTR sendResult; + int timeout = 3000; + size_t len; + const char *str; + Tcl_Obj *objPtr; + WCHAR *wstr; + Tcl_DString ds; + + if (objc == 3) { + str = Tcl_GetString(objv[1]); + len = objv[1]->length; + if ((len < 2) || (*str != '-') || strncmp(str, "-timeout", len)) { + return TCL_BREAK; + } + if (Tcl_GetIntFromObj(interp, objv[2], &timeout) != TCL_OK) { + return TCL_ERROR; + } + } + + str = Tcl_GetString(objv[0]); + len = objv[0]->length; + wstr = (WCHAR *) Tcl_WinUtfToTChar(str, len, &ds); + if (Tcl_DStringLength(&ds) == 0) { + wstr = NULL; + } + + /* + * Use the ignore the result. + */ + + result = SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, + (WPARAM) 0, (LPARAM) wstr, SMTO_ABORTIFHUNG, (UINT) timeout, &sendResult); + Tcl_DStringFree(&ds); + + objPtr = Tcl_NewObj(); + Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewWideIntObj((Tcl_WideInt) result)); + Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewWideIntObj((Tcl_WideInt) sendResult)); + Tcl_SetObjResult(interp, objPtr); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * AppendSystemError -- + * + * This routine formats a Windows system error message and places it into + * the interpreter result. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +AppendSystemError( + Tcl_Interp *interp, /* Current interpreter. */ + DWORD error) /* Result code from error. */ +{ + int length; + TCHAR *tMsgPtr, **tMsgPtrPtr = &tMsgPtr; + const char *msg; + char id[TCL_INTEGER_SPACE], msgBuf[24 + TCL_INTEGER_SPACE]; + Tcl_DString ds; + Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); + + if (Tcl_IsShared(resultPtr)) { + resultPtr = Tcl_DuplicateObj(resultPtr); + } + length = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM + | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error, + MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (TCHAR *) tMsgPtrPtr, + 0, NULL); + if (length == 0) { + sprintf(msgBuf, "unknown error: %ld", error); + msg = msgBuf; + } else { + char *msgPtr; + + Tcl_WinTCharToUtf(tMsgPtr, -1, &ds); + LocalFree(tMsgPtr); + + msgPtr = Tcl_DStringValue(&ds); + length = Tcl_DStringLength(&ds); + + /* + * Trim the trailing CR/LF from the system message. + */ + + if (msgPtr[length-1] == '\n') { + --length; + } + if (msgPtr[length-1] == '\r') { + --length; + } + msgPtr[length] = 0; + msg = msgPtr; + } + + sprintf(id, "%ld", error); + Tcl_SetErrorCode(interp, "WINDOWS", id, msg, NULL); + Tcl_AppendToObj(resultPtr, msg, length); + Tcl_SetObjResult(interp, resultPtr); + + if (length != 0) { + Tcl_DStringFree(&ds); + } +} + +/* + *---------------------------------------------------------------------- + * + * ConvertDWORD -- + * + * This function determines whether a DWORD needs to be byte swapped, and + * returns the appropriately swapped value. + * + * Results: + * Returns a converted DWORD. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static DWORD +ConvertDWORD( + DWORD type, /* Either REG_DWORD or REG_DWORD_BIG_ENDIAN */ + DWORD value) /* The value to be converted. */ +{ + const DWORD order = 1; + DWORD localType; + + /* + * Check to see if the low bit is in the first byte. + */ + + localType = (*((const char *) &order) == 1) + ? REG_DWORD : REG_DWORD_BIG_ENDIAN; + return (type != localType) ? (DWORD) SWAPLONG(value) : value; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c new file mode 100644 index 0000000..ed1a8e5 --- /dev/null +++ b/win/tclWinSerial.c @@ -0,0 +1,2236 @@ +/* + * tclWinSerial.c -- + * + * This file implements the Windows-specific serial port functions, and + * the "serial" channel driver. + * + * Copyright (c) 1999 by Scriptics Corp. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * Serial functionality implemented by Rolf.Schroedter@dlr.de + */ + +#include "tclWinInt.h" + +/* + * The following variable is used to tell whether this module has been + * initialized. + */ + +static int initialized = 0; + +/* + * The serialMutex locks around access to the initialized variable, and it is + * used to protect background threads from being terminated while they are + * using APIs that hold locks. + */ + +TCL_DECLARE_MUTEX(serialMutex) + +/* + * Bit masks used in the flags field of the SerialInfo structure below. + */ + +#define SERIAL_PENDING (1<<0) /* Message is pending in the queue. */ +#define SERIAL_ASYNC (1<<1) /* Channel is non-blocking. */ + +/* + * Bit masks used in the sharedFlags field of the SerialInfo structure below. + */ + +#define SERIAL_EOF (1<<2) /* Serial has reached EOF. */ +#define SERIAL_ERROR (1<<4) + +/* + * Default time to block between checking status on the serial port. + */ + +#define SERIAL_DEFAULT_BLOCKTIME 10 /* 10 msec */ + +/* + * Define Win32 read/write error masks returned by ClearCommError() + */ + +#define SERIAL_READ_ERRORS \ + (CE_RXOVER | CE_OVERRUN | CE_RXPARITY | CE_FRAME | CE_BREAK) +#define SERIAL_WRITE_ERRORS \ + (CE_TXFULL | CE_PTO) + +/* + * This structure describes per-instance data for a serial based channel. + */ + +typedef struct SerialInfo { + HANDLE handle; + struct SerialInfo *nextPtr; /* Pointer to next registered serial. */ + Tcl_Channel channel; /* Pointer to channel structure. */ + int validMask; /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, or TCL_EXCEPTION: indicates + * which operations are valid on the file. */ + int watchMask; /* OR'ed combination of TCL_READABLE, + * TCL_WRITABLE, or TCL_EXCEPTION: indicates + * which events should be reported. */ + int flags; /* State flags, see above for a list. */ + int readable; /* Flag that the channel is readable. */ + int writable; /* Flag that the channel is writable. */ + int blockTime; /* Maximum blocktime in msec. */ + unsigned int lastEventTime; /* Time in milliseconds since last readable + * event. */ + /* Next readable event only after blockTime */ + DWORD error; /* pending error code returned by + * ClearCommError() */ + DWORD lastError; /* last error code, can be fetched with + * fconfigure chan -lasterror */ + DWORD sysBufRead; /* Win32 system buffer size for read ops, + * default=4096 */ + DWORD sysBufWrite; /* Win32 system buffer size for write ops, + * default=4096 */ + + Tcl_ThreadId threadId; /* Thread to which events should be reported. + * This value is used by the reader/writer + * 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. */ + 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 + * writer thread so access must be + * synchronized with the evWritable object. */ + char *writeBuf; /* Current background output buffer. Access is + * synchronized with the evWritable object. */ + int writeBufLen; /* Size of write buffer. Access is + * synchronized with the evWritable object. */ + int toWrite; /* Current amount to be written. Access is + * synchronized with the evWritable object. */ + int writeQueue; /* Number of bytes pending in output queue. + * Offset to DCB.cbInQue. Used to query + * [fconfigure -queue] */ +} SerialInfo; + +typedef struct { + /* + * The following pointer refers to the head of the list of serials that + * are being watched for file events. + */ + + SerialInfo *firstSerialPtr; +} ThreadSpecificData; + +static Tcl_ThreadDataKey dataKey; + +/* + * The following structure is what is added to the Tcl event queue when serial + * events are generated. + */ + +typedef struct { + Tcl_Event header; /* Information that is standard for all + * events. */ + SerialInfo *infoPtr; /* Pointer to serial info structure. Note that + * we still have to verify that the serial + * exists before dereferencing this + * pointer. */ +} SerialEvent; + +/* + * We don't use timeouts. + */ + +static COMMTIMEOUTS no_timeout = { + 0, /* ReadIntervalTimeout */ + 0, /* ReadTotalTimeoutMultiplier */ + 0, /* ReadTotalTimeoutConstant */ + 0, /* WriteTotalTimeoutMultiplier */ + 0, /* WriteTotalTimeoutConstant */ +}; + +/* + * Declarations for functions used only in this file. + */ + +static int SerialBlockProc(ClientData instanceData, int mode); +static void SerialCheckProc(ClientData clientData, int flags); +static int SerialCloseProc(ClientData instanceData, + Tcl_Interp *interp); +static int SerialEventProc(Tcl_Event *evPtr, int flags); +static void SerialExitHandler(ClientData clientData); +static int SerialGetHandleProc(ClientData instanceData, + int direction, ClientData *handlePtr); +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); +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_DString *dsPtr); +static int SerialSetOptionProc(ClientData instanceData, + Tcl_Interp *interp, const char *optionName, + const char *value); +static DWORD WINAPI SerialWriterThread(LPVOID arg); +static void SerialThreadActionProc(ClientData instanceData, + int action); +static int SerialBlockingRead(SerialInfo *infoPtr, LPVOID buf, + DWORD bufSize, LPDWORD lpRead, LPOVERLAPPED osPtr); +static int SerialBlockingWrite(SerialInfo *infoPtr, LPVOID buf, + DWORD bufSize, LPDWORD lpWritten, + LPOVERLAPPED osPtr); + +/* + * This structure describes the channel type structure for command serial + * based IO. + */ + +static const Tcl_ChannelType serialChannelType = { + "serial", /* Type name. */ + TCL_CHANNEL_VERSION_5, /* v5 channel */ + SerialCloseProc, /* Close proc. */ + SerialInputProc, /* Input proc. */ + SerialOutputProc, /* Output proc. */ + NULL, /* Seek proc. */ + SerialSetOptionProc, /* Set option proc. */ + SerialGetOptionProc, /* Get option proc. */ + SerialWatchProc, /* Set up notifier to watch the channel. */ + SerialGetHandleProc, /* Get an OS handle from channel. */ + NULL, /* close2proc. */ + SerialBlockProc, /* Set blocking or non-blocking mode.*/ + NULL, /* flush proc. */ + NULL, /* handler proc. */ + NULL, /* wide seek proc */ + SerialThreadActionProc, /* thread action proc */ + NULL /* truncate */ +}; + +/* + *---------------------------------------------------------------------- + * + * SerialInit -- + * + * This function initializes the static variables for this file. + * + * Results: + * None. + * + * Side effects: + * Creates a new event source. + * + *---------------------------------------------------------------------- + */ + +static ThreadSpecificData * +SerialInit(void) +{ + ThreadSpecificData *tsdPtr; + + /* + * Check the initialized flag first, then check it again in the mutex. + * This is a speed enhancement. + */ + + if (!initialized) { + Tcl_MutexLock(&serialMutex); + if (!initialized) { + initialized = 1; + Tcl_CreateExitHandler(ProcExitHandler, NULL); + } + Tcl_MutexUnlock(&serialMutex); + } + + tsdPtr = (ThreadSpecificData *) TclThreadDataKeyGet(&dataKey); + if (tsdPtr == NULL) { + tsdPtr = TCL_TSD_INIT(&dataKey); + tsdPtr->firstSerialPtr = NULL; + Tcl_CreateEventSource(SerialSetupProc, SerialCheckProc, NULL); + Tcl_CreateThreadExitHandler(SerialExitHandler, NULL); + } + return tsdPtr; +} + +/* + *---------------------------------------------------------------------- + * + * SerialExitHandler -- + * + * This function is called to cleanup the serial module before Tcl is + * unloaded. + * + * Results: + * None. + * + * Side effects: + * Removes the serial event source. + * + *---------------------------------------------------------------------- + */ + +static void +SerialExitHandler( + ClientData clientData) /* Old window proc */ +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + SerialInfo *infoPtr; + + /* + * Clear all eventually pending output. Otherwise Tcl's exit could totally + * block, because it performs a blocking flush on all open channels. Note + * that serial write operations may be blocked due to handshake. + */ + + for (infoPtr = tsdPtr->firstSerialPtr; infoPtr != NULL; + infoPtr = infoPtr->nextPtr) { + PurgeComm(infoPtr->handle, + PURGE_TXABORT | PURGE_RXABORT | PURGE_TXCLEAR | PURGE_RXCLEAR); + } + Tcl_DeleteEventSource(SerialSetupProc, SerialCheckProc, NULL); +} + +/* + *---------------------------------------------------------------------- + * + * ProcExitHandler -- + * + * This function is called to cleanup the process list before Tcl is + * unloaded. + * + * Results: + * None. + * + * Side effects: + * Resets the process list. + * + *---------------------------------------------------------------------- + */ + +static void +ProcExitHandler( + ClientData clientData) /* Old window proc */ +{ + Tcl_MutexLock(&serialMutex); + initialized = 0; + Tcl_MutexUnlock(&serialMutex); +} + +/* + *---------------------------------------------------------------------- + * + * SerialBlockTime -- + * + * Wrapper to set Tcl's block time in msec + * + * Results: + * None. + * + * Side effects: + * Updates the maximum blocking time. + * + *---------------------------------------------------------------------- + */ + +static void +SerialBlockTime( + int msec) /* milli-seconds */ +{ + Tcl_Time blockTime; + + blockTime.sec = msec / 1000; + blockTime.usec = (msec % 1000) * 1000; + Tcl_SetMaxBlockTime(&blockTime); +} + +/* + *---------------------------------------------------------------------- + * + * SerialGetMilliseconds -- + * + * Get current time in milliseconds,ignoring integer overruns. + * + * Results: + * The current time. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static unsigned int +SerialGetMilliseconds(void) +{ + Tcl_Time time; + + Tcl_GetTime(&time); + + return (time.sec * 1000 + time.usec / 1000); +} + +/* + *---------------------------------------------------------------------- + * + * SerialSetupProc -- + * + * This procedure is invoked before Tcl_DoOneEvent blocks waiting for an + * event. + * + * Results: + * None. + * + * Side effects: + * Adjusts the block time if needed. + * + *---------------------------------------------------------------------- + */ + +void +SerialSetupProc( + ClientData data, /* Not used. */ + int flags) /* Event flags as passed to Tcl_DoOneEvent. */ +{ + SerialInfo *infoPtr; + int block = 1; + int msec = INT_MAX; /* min. found block time */ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if (!(flags & TCL_FILE_EVENTS)) { + return; + } + + /* + * Look to see if any events handlers installed. If they are, do not + * block. + */ + + for (infoPtr=tsdPtr->firstSerialPtr ; infoPtr!=NULL ; + infoPtr=infoPtr->nextPtr) { + if (infoPtr->watchMask & TCL_WRITABLE) { + if (WaitForSingleObject(infoPtr->evWritable, 0) != WAIT_TIMEOUT) { + block = 0; + msec = min(msec, infoPtr->blockTime); + } + } + if (infoPtr->watchMask & TCL_READABLE) { + block = 0; + msec = min(msec, infoPtr->blockTime); + } + } + + if (!block) { + SerialBlockTime(msec); + } +} + +/* + *---------------------------------------------------------------------- + * + * SerialCheckProc -- + * + * This procedure is called by Tcl_DoOneEvent to check the serial event + * source for events. + * + * Results: + * None. + * + * Side effects: + * May queue an event. + * + *---------------------------------------------------------------------- + */ + +static void +SerialCheckProc( + ClientData data, /* Not used. */ + int flags) /* Event flags as passed to Tcl_DoOneEvent. */ +{ + SerialInfo *infoPtr; + SerialEvent *evPtr; + int needEvent; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + COMSTAT cStat; + unsigned int time; + + if (!(flags & TCL_FILE_EVENTS)) { + return; + } + + /* + * Queue events for any ready serials that don't already have events + * queued. + */ + + for (infoPtr=tsdPtr->firstSerialPtr ; infoPtr!=NULL ; + infoPtr=infoPtr->nextPtr) { + if (infoPtr->flags & SERIAL_PENDING) { + continue; + } + + needEvent = 0; + + /* + * If WRITABLE watch mask is set look for infoPtr->evWritable object. + */ + + if (infoPtr->watchMask & TCL_WRITABLE && + WaitForSingleObject(infoPtr->evWritable, 0) != WAIT_TIMEOUT) { + infoPtr->writable = 1; + needEvent = 1; + } + + /* + * If READABLE watch mask is set call ClearCommError to poll cbInQue. + * Window errors are ignored here. + */ + + if (infoPtr->watchMask & TCL_READABLE) { + if (ClearCommError(infoPtr->handle, &infoPtr->error, &cStat)) { + /* + * Look for characters already pending in windows queue. If + * they are, poll. + */ + + if (infoPtr->watchMask & TCL_READABLE) { + /* + * Force fileevent after serial read error. + */ + + if ((cStat.cbInQue > 0) || + (infoPtr->error & SERIAL_READ_ERRORS)) { + infoPtr->readable = 1; + time = SerialGetMilliseconds(); + if ((unsigned int) (time - infoPtr->lastEventTime) + >= (unsigned int) infoPtr->blockTime) { + needEvent = 1; + infoPtr->lastEventTime = time; + } + } + } + } + } + + /* + * Queue an event if the serial is signaled for reading or writing. + */ + + if (needEvent) { + infoPtr->flags |= SERIAL_PENDING; + evPtr = ckalloc(sizeof(SerialEvent)); + evPtr->header.proc = SerialEventProc; + evPtr->infoPtr = infoPtr; + Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * SerialBlockProc -- + * + * Set blocking or non-blocking mode on channel. + * + * Results: + * 0 if successful, errno when failed. + * + * Side effects: + * Sets the device into blocking or non-blocking mode. + * + *---------------------------------------------------------------------- + */ + +static int +SerialBlockProc( + ClientData instanceData, /* Instance data for channel. */ + int mode) /* TCL_MODE_BLOCKING or + * TCL_MODE_NONBLOCKING. */ +{ + int errorCode = 0; + SerialInfo *infoPtr = (SerialInfo *) instanceData; + + /* + * Only serial READ can be switched between blocking & nonblocking using + * COMMTIMEOUTS. Serial write emulates blocking & nonblocking by the + * SerialWriterThread. + */ + + if (mode == TCL_MODE_NONBLOCKING) { + infoPtr->flags |= SERIAL_ASYNC; + } else { + infoPtr->flags &= ~(SERIAL_ASYNC); + } + return errorCode; +} + +/* + *---------------------------------------------------------------------- + * + * SerialCloseProc -- + * + * Closes a serial based IO channel. + * + * Results: + * 0 on success, errno otherwise. + * + * Side effects: + * Closes the physical channel. + * + *---------------------------------------------------------------------- + */ + +static int +SerialCloseProc( + ClientData instanceData, /* Pointer to SerialInfo structure. */ + Tcl_Interp *interp) /* For error reporting. */ +{ + SerialInfo *serialPtr = (SerialInfo *) instanceData; + int errorCode, result = 0; + SerialInfo *infoPtr, **nextPtrPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + errorCode = 0; + + if (serialPtr->validMask & TCL_READABLE) { + PurgeComm(serialPtr->handle, PURGE_RXABORT | PURGE_RXCLEAR); + CloseHandle(serialPtr->osRead.hEvent); + } + serialPtr->validMask &= ~TCL_READABLE; + + if (serialPtr->writeThread) { + + TclPipeThreadStop(&serialPtr->writeTI, serialPtr->writeThread); + + CloseHandle(serialPtr->osWrite.hEvent); + CloseHandle(serialPtr->evWritable); + CloseHandle(serialPtr->writeThread); + serialPtr->writeThread = NULL; + + PurgeComm(serialPtr->handle, PURGE_TXABORT | PURGE_TXCLEAR); + } + serialPtr->validMask &= ~TCL_WRITABLE; + + DeleteCriticalSection(&serialPtr->csWrite); + + /* + * 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 + * another. + */ + + if (!TclInThreadExit() + || ((GetStdHandle(STD_INPUT_HANDLE) != serialPtr->handle) + && (GetStdHandle(STD_OUTPUT_HANDLE) != serialPtr->handle) + && (GetStdHandle(STD_ERROR_HANDLE) != serialPtr->handle))) { + if (CloseHandle(serialPtr->handle) == FALSE) { + TclWinConvertError(GetLastError()); + errorCode = errno; + } + } + + serialPtr->watchMask &= serialPtr->validMask; + + /* + * Remove the file from the list of watched files. + */ + + for (nextPtrPtr=&(tsdPtr->firstSerialPtr), infoPtr=*nextPtrPtr; + infoPtr!=NULL; + nextPtrPtr=&infoPtr->nextPtr, infoPtr=*nextPtrPtr) { + if (infoPtr == (SerialInfo *)serialPtr) { + *nextPtrPtr = infoPtr->nextPtr; + break; + } + } + + /* + * Wrap the error file into a channel and give it to the cleanup routine. + */ + + if (serialPtr->writeBuf != NULL) { + ckfree(serialPtr->writeBuf); + serialPtr->writeBuf = NULL; + } + ckfree(serialPtr); + + if (errorCode == 0) { + return result; + } + return errorCode; +} + +/* + *---------------------------------------------------------------------- + * + * SerialBlockingRead -- + * + * Perform a blocking read into the buffer given. Returns count of how + * many bytes were actually read, and an error indication. + * + * Results: + * A count of how many bytes were read is returned and an error + * indication is returned. + * + * Side effects: + * Reads input from the actual channel. + * + *---------------------------------------------------------------------- + */ + +static int +SerialBlockingRead( + SerialInfo *infoPtr, /* Serial info structure */ + LPVOID buf, /* The input buffer pointer */ + DWORD bufSize, /* The number of bytes to read */ + LPDWORD lpRead, /* Returns number of bytes read */ + LPOVERLAPPED osPtr) /* OVERLAPPED structure */ +{ + /* + * Perform overlapped blocking read. + * 1. Reset the overlapped event + * 2. Start overlapped read operation + * 3. Wait for completion + */ + + /* + * Set Offset to ZERO, otherwise NT4.0 may report an error. + */ + + osPtr->Offset = osPtr->OffsetHigh = 0; + ResetEvent(osPtr->hEvent); + if (!ReadFile(infoPtr->handle, buf, bufSize, lpRead, osPtr)) { + if (GetLastError() != ERROR_IO_PENDING) { + /* + * ReadFile failed, but it isn't delayed. Report error. + */ + + return FALSE; + } else { + /* + * Read is pending, wait for completion, timeout? + */ + + if (!GetOverlappedResult(infoPtr->handle, osPtr, lpRead, TRUE)) { + return FALSE; + } + } + } else { + /* + * ReadFile completed immediately. + */ + } + return TRUE; +} + +/* + *---------------------------------------------------------------------- + * + * SerialBlockingWrite -- + * + * Perform a blocking write from the buffer given. Returns count of how + * many bytes were actually written, and an error indication. + * + * Results: + * A count of how many bytes were written is returned and an error + * indication is returned. + * + * Side effects: + * Writes output to the actual channel. + * + *---------------------------------------------------------------------- + */ + +static int +SerialBlockingWrite( + SerialInfo *infoPtr, /* Serial info structure */ + LPVOID buf, /* The output buffer pointer */ + DWORD bufSize, /* The number of bytes to write */ + LPDWORD lpWritten, /* Returns number of bytes written */ + LPOVERLAPPED osPtr) /* OVERLAPPED structure */ +{ + int result; + + /* + * Perform overlapped blocking write. + * 1. Reset the overlapped event + * 2. Remove these bytes from the output queue counter + * 3. Start overlapped write operation + * 3. Remove these bytes from the output queue counter + * 4. Wait for completion + * 5. Adjust the output queue counter + */ + + ResetEvent(osPtr->hEvent); + + EnterCriticalSection(&infoPtr->csWrite); + infoPtr->writeQueue -= bufSize; + + /* + * Set Offset to ZERO, otherwise NT4.0 may report an error + */ + + osPtr->Offset = osPtr->OffsetHigh = 0; + result = WriteFile(infoPtr->handle, buf, bufSize, lpWritten, osPtr); + LeaveCriticalSection(&infoPtr->csWrite); + + if (result == FALSE) { + int err = GetLastError(); + + switch (err) { + case ERROR_IO_PENDING: + /* + * Write is pending, wait for completion. + */ + + if (!GetOverlappedResult(infoPtr->handle, osPtr, lpWritten, + TRUE)) { + return FALSE; + } + break; + case ERROR_COUNTER_TIMEOUT: + /* + * Write timeout handled in SerialOutputProc. + */ + + break; + default: + /* + * WriteFile failed, but it isn't delayed. Report error. + */ + + return FALSE; + } + } else { + /* + * WriteFile completed immediately. + */ + } + + EnterCriticalSection(&infoPtr->csWrite); + infoPtr->writeQueue += (*lpWritten - bufSize); + LeaveCriticalSection(&infoPtr->csWrite); + + return TRUE; +} + +/* + *---------------------------------------------------------------------- + * + * SerialInputProc -- + * + * Reads input from the IO channel into the buffer given. Returns count + * of how many bytes were actually read, and an error indication. + * + * Results: + * A count of how many bytes were read is returned and an error + * indication is returned in an output argument. + * + * Side effects: + * Reads input from the actual channel. + * + *---------------------------------------------------------------------- + */ + +static int +SerialInputProc( + ClientData instanceData, /* Serial state. */ + char *buf, /* Where to store data read. */ + int bufSize, /* How much space is available in the + * buffer? */ + int *errorCode) /* Where to store error code. */ +{ + SerialInfo *infoPtr = (SerialInfo *) instanceData; + DWORD bytesRead = 0; + COMSTAT cStat; + + *errorCode = 0; + + /* + * Check if there is a CommError pending from SerialCheckProc + */ + + if (infoPtr->error & SERIAL_READ_ERRORS) { + goto commError; + } + + /* + * Look for characters already pending in windows queue. This is the + * mainly restored good old code from Tcl8.0 + */ + + if (ClearCommError(infoPtr->handle, &infoPtr->error, &cStat)) { + /* + * Check for errors here, but not in the evSetup/Check procedures. + */ + + if (infoPtr->error & SERIAL_READ_ERRORS) { + goto commError; + } + if (infoPtr->flags & SERIAL_ASYNC) { + /* + * NON_BLOCKING mode: Avoid blocking by reading more bytes than + * available in input buffer. + */ + + if (cStat.cbInQue > 0) { + if ((DWORD) bufSize > cStat.cbInQue) { + bufSize = cStat.cbInQue; + } + } else { + errno = *errorCode = EWOULDBLOCK; + return -1; + } + } else { + /* + * BLOCKING mode: Tcl trys to read a full buffer of 4 kBytes here. + */ + + if (cStat.cbInQue > 0) { + if ((DWORD) bufSize > cStat.cbInQue) { + bufSize = cStat.cbInQue; + } + } else { + bufSize = 1; + } + } + } + + if (bufSize == 0) { + return bytesRead = 0; + } + + /* + * Perform blocking read. Doesn't block in non-blocking mode, because we + * checked the number of available bytes. + */ + + if (SerialBlockingRead(infoPtr, (LPVOID) buf, (DWORD) bufSize, &bytesRead, + &infoPtr->osRead) == FALSE) { + TclWinConvertError(GetLastError()); + *errorCode = errno; + return -1; + } + return bytesRead; + + commError: + infoPtr->lastError = infoPtr->error; + /* save last error code */ + infoPtr->error = 0; /* reset error code */ + *errorCode = EIO; /* to return read-error only once */ + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * SerialOutputProc -- + * + * Writes the given output on the IO channel. Returns count of how many + * characters were actually written, and an error indication. + * + * Results: + * A count of how many characters were written is returned and an error + * indication is returned in an output argument. + * + * Side effects: + * Writes output on the actual channel. + * + *---------------------------------------------------------------------- + */ + +static int +SerialOutputProc( + ClientData instanceData, /* Serial state. */ + const char *buf, /* The data buffer. */ + int toWrite, /* How many bytes to write? */ + int *errorCode) /* Where to store error code. */ +{ + SerialInfo *infoPtr = (SerialInfo *) instanceData; + DWORD bytesWritten, timeout; + + *errorCode = 0; + + /* + * At EXIT Tcl trys to flush all open channels in blocking mode. We avoid + * blocking output after ExitProc or CloseHandler(chan) has been called by + * checking the corrresponding variables. + */ + + if (!initialized || TclInExit()) { + return toWrite; + } + + /* + * Check if there is a CommError pending from SerialCheckProc + */ + + if (infoPtr->error & SERIAL_WRITE_ERRORS) { + infoPtr->lastError = infoPtr->error; + /* save last error code */ + infoPtr->error = 0; /* reset error code */ + errno = EIO; + goto error; + } + + timeout = (infoPtr->flags & SERIAL_ASYNC) ? 0 : INFINITE; + if (WaitForSingleObject(infoPtr->evWritable, timeout) == WAIT_TIMEOUT) { + /* + * The writer thread is blocked waiting for a write to complete and + * the channel is in non-blocking mode. + */ + + errno = EWOULDBLOCK; + goto error1; + } + + /* + * Check for a background error on the last write. + */ + + if (infoPtr->writeError) { + TclWinConvertError(infoPtr->writeError); + infoPtr->writeError = 0; + goto error1; + } + + /* + * Remember the number of bytes in output queue + */ + + EnterCriticalSection(&infoPtr->csWrite); + infoPtr->writeQueue += toWrite; + LeaveCriticalSection(&infoPtr->csWrite); + + if (infoPtr->flags & SERIAL_ASYNC) { + /* + * The serial is non-blocking, so copy the data into the output buffer + * and restart the writer thread. + */ + + if (toWrite > infoPtr->writeBufLen) { + /* + * Reallocate the buffer to be large enough to hold the data. + */ + + if (infoPtr->writeBuf) { + ckfree(infoPtr->writeBuf); + } + infoPtr->writeBufLen = toWrite; + infoPtr->writeBuf = ckalloc(toWrite); + } + memcpy(infoPtr->writeBuf, buf, (size_t) toWrite); + infoPtr->toWrite = toWrite; + ResetEvent(infoPtr->evWritable); + TclPipeThreadSignal(&infoPtr->writeTI); + bytesWritten = (DWORD) toWrite; + + } else { + /* + * In the blocking case, just try to write the buffer directly. This + * avoids an unnecessary copy. + */ + + if (!SerialBlockingWrite(infoPtr, (LPVOID) buf, (DWORD) toWrite, + &bytesWritten, &infoPtr->osWrite)) { + goto writeError; + } + if (bytesWritten != (DWORD) toWrite) { + /* + * Write timeout. + */ + infoPtr->lastError |= CE_PTO; + errno = EIO; + goto error; + } + } + + return (int) bytesWritten; + + writeError: + TclWinConvertError(GetLastError()); + + error: + /* + * Reset the output queue counter on error during blocking output + */ + + /* + * EnterCriticalSection(&infoPtr->csWrite); + * infoPtr->writeQueue = 0; + * LeaveCriticalSection(&infoPtr->csWrite); + */ + error1: + *errorCode = errno; + return -1; +} + +/* + *---------------------------------------------------------------------- + * + * SerialEventProc -- + * + * This function is invoked by Tcl_ServiceEvent when a file event reaches + * the front of the event queue. This procedure invokes Tcl_NotifyChannel + * on the serial. + * + * 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. + * + * Side effects: + * Whatever the notifier callback does. + * + *---------------------------------------------------------------------- + */ + +static int +SerialEventProc( + Tcl_Event *evPtr, /* Event to service. */ + int flags) /* Flags that indicate what events to handle, + * such as TCL_FILE_EVENTS. */ +{ + SerialEvent *serialEvPtr = (SerialEvent *)evPtr; + SerialInfo *infoPtr; + int mask; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if (!(flags & TCL_FILE_EVENTS)) { + return 0; + } + + /* + * Search through the list of watched serials for the one whose handle + * matches the event. We do this rather than simply dereferencing the + * handle in the event so that serials can be deleted while the event is + * in the queue. + */ + + for (infoPtr = tsdPtr->firstSerialPtr; infoPtr != NULL; + infoPtr = infoPtr->nextPtr) { + if (serialEvPtr->infoPtr == infoPtr) { + infoPtr->flags &= ~(SERIAL_PENDING); + break; + } + } + + /* + * Remove stale events. + */ + + if (!infoPtr) { + return 1; + } + + /* + * Check to see if the serial is readable. Note that we can't tell if a + * serial is writable, so we always report it as being writable unless we + * have detected EOF. + */ + + mask = 0; + if (infoPtr->watchMask & TCL_WRITABLE) { + if (infoPtr->writable) { + mask |= TCL_WRITABLE; + infoPtr->writable = 0; + } + } + + if (infoPtr->watchMask & TCL_READABLE) { + if (infoPtr->readable) { + mask |= TCL_READABLE; + infoPtr->readable = 0; + } + } + + /* + * Inform the channel of the events. + */ + + Tcl_NotifyChannel(infoPtr->channel, infoPtr->watchMask & mask); + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * SerialWatchProc -- + * + * Called by the notifier to set up to watch for events on this channel. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +SerialWatchProc( + ClientData instanceData, /* Serial state. */ + int mask) /* What events to watch for, OR-ed combination + * of TCL_READABLE, TCL_WRITABLE and + * TCL_EXCEPTION. */ +{ + SerialInfo **nextPtrPtr, *ptr; + SerialInfo *infoPtr = (SerialInfo *) instanceData; + int oldMask = infoPtr->watchMask; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + /* + * Since the file is always ready for events, we set the block time so we + * will poll. + */ + + infoPtr->watchMask = mask & infoPtr->validMask; + if (infoPtr->watchMask) { + if (!oldMask) { + infoPtr->nextPtr = tsdPtr->firstSerialPtr; + tsdPtr->firstSerialPtr = infoPtr; + } + SerialBlockTime(infoPtr->blockTime); + } else if (oldMask) { + /* + * Remove the serial port from the list of watched serial ports. + */ + + for (nextPtrPtr=&(tsdPtr->firstSerialPtr), ptr=*nextPtrPtr; ptr!=NULL; + nextPtrPtr=&ptr->nextPtr, ptr=*nextPtrPtr) { + if (infoPtr == ptr) { + *nextPtrPtr = ptr->nextPtr; + break; + } + } + } +} + +/* + *---------------------------------------------------------------------- + * + * SerialGetHandleProc -- + * + * Called from Tcl_GetChannelHandle to retrieve OS handles from inside a + * command serial port 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. + * + *---------------------------------------------------------------------- + */ + +static int +SerialGetHandleProc( + ClientData instanceData, /* The serial state. */ + int direction, /* TCL_READABLE or TCL_WRITABLE */ + ClientData *handlePtr) /* Where to store the handle. */ +{ + SerialInfo *infoPtr = (SerialInfo *) instanceData; + + *handlePtr = (ClientData) infoPtr->handle; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * SerialWriterThread -- + * + * This function runs in a separate thread and writes data onto a serial. + * + * Results: + * Always returns 0. + * + * Side effects: + * Signals the main thread when an output operation is completed. May + * cause the main thread to wake up by posting a message. + * + *---------------------------------------------------------------------- + */ + +static DWORD WINAPI +SerialWriterThread( + LPVOID arg) +{ + 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. */ + + for (;;) { + /* + * Wait for the main thread to signal before attempting to write. + */ + if (!TclPipeThreadWaitForSignal(&pipeTI)) { + /* exit */ + break; + } + infoPtr = (SerialInfo *)pipeTI->clientData; + + buf = infoPtr->writeBuf; + toWrite = infoPtr->toWrite; + + myWrite.hEvent = CreateEvent(NULL, TRUE, FALSE, NULL); + + /* + * Loop until all of the bytes are written or an error occurs. + */ + + while (toWrite > 0) { + /* + * Check for pending writeError. Ignore all write operations until + * the user has been notified. + */ + + if (infoPtr->writeError) { + break; + } + if (SerialBlockingWrite(infoPtr, (LPVOID) buf, (DWORD) toWrite, + &bytesWritten, &myWrite) == FALSE) { + infoPtr->writeError = GetLastError(); + break; + } + if (bytesWritten != toWrite) { + /* + * Write timeout. + */ + + infoPtr->writeError = ERROR_WRITE_FAULT; + break; + } + toWrite -= bytesWritten; + buf += bytesWritten; + } + + CloseHandle(myWrite.hEvent); + + /* + * Signal the main thread by signalling the evWritable event and then + * waking up the notifier thread. + */ + + SetEvent(infoPtr->evWritable); + + /* + * Alert the foreground thread. Note that we need to treat this like a + * critical section so the foreground thread does not terminate this + * thread while we are holding a mutex in the notifier code. + */ + + Tcl_MutexLock(&serialMutex); + if (infoPtr->threadId != NULL) { + /* + * TIP #218: When in flight ignore the event, no one will receive + * it anyway. + */ + + Tcl_ThreadAlert(infoPtr->threadId); + } + Tcl_MutexUnlock(&serialMutex); + } + + /* Worker exit, so inform the main thread or free TI-structure (if owned) */ + TclPipeThreadExit(&pipeTI); + + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclWinSerialOpen -- + * + * Opens or Reopens the serial port with the OVERLAPPED FLAG set + * + * Results: + * Returns the new handle, or INVALID_HANDLE_VALUE. + * If an existing channel is specified it is closed and reopened. + * + * Side effects: + * May close/reopen the original handle + * + *---------------------------------------------------------------------- + */ + +HANDLE +TclWinSerialOpen( + HANDLE handle, + const TCHAR *name, + DWORD access) +{ + SerialInit(); + + /* + * If an open channel is specified, close it + */ + + if ( handle != INVALID_HANDLE_VALUE && CloseHandle(handle) == FALSE) { + return INVALID_HANDLE_VALUE; + } + + /* + * Multithreaded I/O needs the overlapped flag set otherwise + * ClearCommError blocks under Windows NT/2000 until serial output is + * finished + */ + + handle = CreateFile(name, access, 0, 0, OPEN_EXISTING, + FILE_FLAG_OVERLAPPED, 0); + + return handle; +} + +/* + *---------------------------------------------------------------------- + * + * TclWinOpenSerialChannel -- + * + * Constructs a Serial port channel for the specified standard OS handle. + * This is a helper function to break up the construction of channels + * into File, Console, or Serial. + * + * Results: + * Returns the new channel, or NULL. + * + * Side effects: + * May open the channel + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +TclWinOpenSerialChannel( + HANDLE handle, + char *channelName, + int permissions) +{ + SerialInfo *infoPtr; + + SerialInit(); + + infoPtr = ckalloc(sizeof(SerialInfo)); + memset(infoPtr, 0, sizeof(SerialInfo)); + + infoPtr->validMask = permissions; + infoPtr->handle = handle; + infoPtr->channel = (Tcl_Channel) NULL; + infoPtr->readable = 0; + infoPtr->writable = 1; + infoPtr->toWrite = infoPtr->writeQueue = 0; + infoPtr->blockTime = SERIAL_DEFAULT_BLOCKTIME; + infoPtr->lastEventTime = 0; + infoPtr->lastError = infoPtr->error = 0; + infoPtr->threadId = Tcl_GetCurrentThread(); + infoPtr->sysBufRead = 4096; + infoPtr->sysBufWrite = 4096; + + /* + * Use the pointer to keep the channel names unique, in case the handles + * are shared between multiple channels (stdin/stdout). + */ + + sprintf(channelName, "file%" TCL_I_MODIFIER "x", (size_t) infoPtr); + + infoPtr->channel = Tcl_CreateChannel(&serialChannelType, channelName, + infoPtr, permissions); + + + SetupComm(handle, infoPtr->sysBufRead, infoPtr->sysBufWrite); + PurgeComm(handle, + PURGE_TXABORT | PURGE_RXABORT | PURGE_TXCLEAR | PURGE_RXCLEAR); + + /* + * Default is blocking. + */ + + SetCommTimeouts(handle, &no_timeout); + + InitializeCriticalSection(&infoPtr->csWrite); + if (permissions & TCL_READABLE) { + infoPtr->osRead.hEvent = CreateEvent(NULL, TRUE, FALSE, NULL); + } + if (permissions & TCL_WRITABLE) { + /* + * Initially the channel is writable and the writeThread is idle. + */ + + infoPtr->osWrite.hEvent = CreateEvent(NULL, TRUE, FALSE, NULL); + infoPtr->evWritable = CreateEvent(NULL, TRUE, TRUE, NULL); + infoPtr->writeThread = CreateThread(NULL, 256, SerialWriterThread, + TclPipeThreadCreateTI(&infoPtr->writeTI, infoPtr, + infoPtr->evWritable), 0, NULL); + } + + /* + * Files have default translation of AUTO and ^Z eof char, which means + * that a ^Z will be accepted as EOF when reading. + */ + + Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto"); + Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}"); + + return infoPtr->channel; +} + +/* + *---------------------------------------------------------------------- + * + * SerialErrorStr -- + * + * Converts a Win32 serial error code to a list of readable errors. + * + * Results: + * None. + * + * Side effects: + * Generates readable errors in the supplied DString. + * + *---------------------------------------------------------------------- + */ + +static void +SerialErrorStr( + DWORD error, /* Win32 serial error code. */ + Tcl_DString *dsPtr) /* Where to store string. */ +{ + if (error & CE_RXOVER) { + Tcl_DStringAppendElement(dsPtr, "RXOVER"); + } + if (error & CE_OVERRUN) { + Tcl_DStringAppendElement(dsPtr, "OVERRUN"); + } + if (error & CE_RXPARITY) { + Tcl_DStringAppendElement(dsPtr, "RXPARITY"); + } + if (error & CE_FRAME) { + Tcl_DStringAppendElement(dsPtr, "FRAME"); + } + if (error & CE_BREAK) { + Tcl_DStringAppendElement(dsPtr, "BREAK"); + } + if (error & CE_TXFULL) { + Tcl_DStringAppendElement(dsPtr, "TXFULL"); + } + if (error & CE_PTO) { /* PTO used to signal WRITE-TIMEOUT */ + Tcl_DStringAppendElement(dsPtr, "TIMEOUT"); + } + if (error & ~((DWORD) (SERIAL_READ_ERRORS | SERIAL_WRITE_ERRORS))) { + char buf[TCL_INTEGER_SPACE + 1]; + + wsprintfA(buf, "%d", error); + Tcl_DStringAppendElement(dsPtr, buf); + } +} + +/* + *---------------------------------------------------------------------- + * + * SerialModemStatusStr -- + * + * Converts a Win32 modem status list of readable flags + * + * Result: + * None. + * + * Side effects: + * Appends modem status flag strings to the given DString. + * + *---------------------------------------------------------------------- + */ + +static void +SerialModemStatusStr( + DWORD status, /* Win32 modem status. */ + Tcl_DString *dsPtr) /* Where to store string. */ +{ + Tcl_DStringAppendElement(dsPtr, "CTS"); + Tcl_DStringAppendElement(dsPtr, (status & MS_CTS_ON) ? "1" : "0"); + Tcl_DStringAppendElement(dsPtr, "DSR"); + Tcl_DStringAppendElement(dsPtr, (status & MS_DSR_ON) ? "1" : "0"); + Tcl_DStringAppendElement(dsPtr, "RING"); + Tcl_DStringAppendElement(dsPtr, (status & MS_RING_ON) ? "1" : "0"); + Tcl_DStringAppendElement(dsPtr, "DCD"); + Tcl_DStringAppendElement(dsPtr, (status & MS_RLSD_ON) ? "1" : "0"); +} + +/* + *---------------------------------------------------------------------- + * + * SerialSetOptionProc -- + * + * Sets an option on a channel. + * + * Results: + * A standard Tcl result. Also sets the interp's result on error if + * interp is not NULL. + * + * Side effects: + * May modify an option on a device. + * + *---------------------------------------------------------------------- + */ + +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. */ +{ + SerialInfo *infoPtr; + DCB dcb; + BOOL result, flag; + size_t len, vlen; + Tcl_DString ds; + const TCHAR *native; + int argc; + const char **argv; + + infoPtr = (SerialInfo *) instanceData; + + /* + * Parse options. This would be far easier if we had Tcl_Objs to work with + * as that would let us use Tcl_GetIndexFromObj()... + */ + + len = strlen(optionName); + vlen = strlen(value); + + /* + * Option -mode baud,parity,databits,stopbits + */ + + if ((len > 2) && (strncmp(optionName, "-mode", len) == 0)) { + if (!GetCommState(infoPtr->handle, &dcb)) { + goto getStateFailed; + } + native = Tcl_WinUtfToTChar(value, -1, &ds); + result = BuildCommDCB(native, &dcb); + Tcl_DStringFree(&ds); + + if (result == FALSE) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad value \"%s\" for -mode: should be baud,parity,data,stop", + value)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL); + } + return TCL_ERROR; + } + + /* + * Default settings for serial communications. + */ + + dcb.fBinary = TRUE; + dcb.fErrorChar = FALSE; + dcb.fNull = FALSE; + dcb.fAbortOnError = FALSE; + + if (!SetCommState(infoPtr->handle, &dcb)) { + goto setStateFailed; + } + return TCL_OK; + } + + /* + * Option -handshake none|xonxoff|rtscts|dtrdsr + */ + + if ((len > 1) && (strncmp(optionName, "-handshake", len) == 0)) { + if (!GetCommState(infoPtr->handle, &dcb)) { + goto getStateFailed; + } + + /* + * Reset all handshake options. DTR and RTS are ON by default. + */ + + dcb.fOutX = dcb.fInX = FALSE; + dcb.fOutxCtsFlow = dcb.fOutxDsrFlow = dcb.fDsrSensitivity = FALSE; + dcb.fDtrControl = DTR_CONTROL_ENABLE; + dcb.fRtsControl = RTS_CONTROL_ENABLE; + dcb.fTXContinueOnXoff = FALSE; + + /* + * Adjust the handshake limits. Yes, the XonXoff limits seem to + * influence even hardware handshake. + */ + + dcb.XonLim = (WORD) (infoPtr->sysBufRead*1/2); + dcb.XoffLim = (WORD) (infoPtr->sysBufRead*1/4); + + if (strncasecmp(value, "NONE", vlen) == 0) { + /* + * Leave all handshake options disabled. + */ + } else if (strncasecmp(value, "XONXOFF", vlen) == 0) { + dcb.fOutX = dcb.fInX = TRUE; + } else if (strncasecmp(value, "RTSCTS", vlen) == 0) { + dcb.fOutxCtsFlow = TRUE; + dcb.fRtsControl = RTS_CONTROL_HANDSHAKE; + } else if (strncasecmp(value, "DTRDSR", vlen) == 0) { + dcb.fOutxDsrFlow = TRUE; + dcb.fDtrControl = DTR_CONTROL_HANDSHAKE; + } else { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad value \"%s\" for -handshake: must be one of" + " xonxoff, rtscts, dtrdsr or none", value)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "HANDSHAKE", NULL); + } + return TCL_ERROR; + } + + if (!SetCommState(infoPtr->handle, &dcb)) { + goto setStateFailed; + } + return TCL_OK; + } + + /* + * Option -xchar {\x11 \x13} + */ + + if ((len > 1) && (strncmp(optionName, "-xchar", len) == 0)) { + if (!GetCommState(infoPtr->handle, &dcb)) { + goto getStateFailed; + } + + if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) { + return TCL_ERROR; + } + if (argc != 2) { + badXchar: + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad value for -xchar: should be a list of" + " two elements with each a single character", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "XCHAR", NULL); + } + ckfree(argv); + return TCL_ERROR; + } + + /* + * These dereferences are safe, even in the zero-length string cases, + * because that just makes the xon/xoff character into NUL. When the + * character looks like it is UTF-8 encoded, decode it before casting + * into the format required for the Win guts. Note that this does not + * convert character sets; it is expected that when people set the + * control characters to something large and custom, they'll know the + * hex/octal value rather than the printable form. + */ + + dcb.XonChar = argv[0][0]; + dcb.XoffChar = argv[1][0]; + if (argv[0][0] & 0x80 || argv[1][0] & 0x80) { + Tcl_UniChar character; + int charLen; + + charLen = Tcl_UtfToUniChar(argv[0], &character); + if (argv[0][charLen]) { + goto badXchar; + } + dcb.XonChar = (char) character; + charLen = Tcl_UtfToUniChar(argv[1], &character); + if (argv[1][charLen]) { + goto badXchar; + } + dcb.XoffChar = (char) character; + } + ckfree(argv); + + if (!SetCommState(infoPtr->handle, &dcb)) { + goto setStateFailed; + } + return TCL_OK; + } + + /* + * Option -ttycontrol {DTR 1 RTS 0 BREAK 0} + */ + + if ((len > 4) && (strncmp(optionName, "-ttycontrol", len) == 0)) { + int i, result = TCL_OK; + + if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) { + return TCL_ERROR; + } + if ((argc % 2) == 1) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad value \"%s\" for -ttycontrol: should be " + "a list of signal,value pairs", value)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "TTYCONTROL", NULL); + } + ckfree(argv); + return TCL_ERROR; + } + + for (i = 0; i < argc - 1; i += 2) { + if (Tcl_GetBoolean(interp, argv[i+1], &flag) == TCL_ERROR) { + result = TCL_ERROR; + break; + } + if (strncasecmp(argv[i], "DTR", strlen(argv[i])) == 0) { + if (!EscapeCommFunction(infoPtr->handle, + (DWORD) (flag ? SETDTR : CLRDTR))) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can't set DTR signal", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", + "FCONFIGURE", "TTY_SIGNAL", NULL); + } + result = TCL_ERROR; + break; + } + } else if (strncasecmp(argv[i], "RTS", strlen(argv[i])) == 0) { + if (!EscapeCommFunction(infoPtr->handle, + (DWORD) (flag ? SETRTS : CLRRTS))) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can't set RTS signal", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", + "FCONFIGURE", "TTY_SIGNAL", NULL); + } + result = TCL_ERROR; + break; + } + } else if (strncasecmp(argv[i], "BREAK", strlen(argv[i])) == 0) { + if (!EscapeCommFunction(infoPtr->handle, + (DWORD) (flag ? SETBREAK : CLRBREAK))) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can't set BREAK signal", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", + "FCONFIGURE", "TTY_SIGNAL", NULL); + } + result = TCL_ERROR; + break; + } + } else { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad signal name \"%s\" for -ttycontrol: must be" + " DTR, RTS or BREAK", argv[i])); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "TTY_SIGNAL", + NULL); + } + result = TCL_ERROR; + break; + } + } + + ckfree(argv); + return result; + } + + /* + * Option -sysbuffer {read_size write_size} + * Option -sysbuffer read_size + */ + + if ((len > 1) && (strncmp(optionName, "-sysbuffer", len) == 0)) { + /* + * -sysbuffer 4096 or -sysbuffer {64536 4096} + */ + + size_t inSize = (size_t) -1, outSize = (size_t) -1; + + if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) { + return TCL_ERROR; + } + if (argc == 1) { + inSize = atoi(argv[0]); + outSize = infoPtr->sysBufWrite; + } else if (argc == 2) { + inSize = atoi(argv[0]); + outSize = atoi(argv[1]); + } + ckfree(argv); + + if ((argc < 1) || (argc > 2) || (inSize <= 0) || (outSize <= 0)) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad value \"%s\" for -sysbuffer: should be " + "a list of one or two integers > 0", value)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "SYS_BUFFER", NULL); + } + return TCL_ERROR; + } + + if (!SetupComm(infoPtr->handle, inSize, outSize)) { + if (interp != NULL) { + TclWinConvertError(GetLastError()); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't setup comm buffers: %s", + Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + infoPtr->sysBufRead = inSize; + infoPtr->sysBufWrite = outSize; + + /* + * Adjust the handshake limits. Yes, the XonXoff limits seem to + * influence even hardware handshake. + */ + + if (!GetCommState(infoPtr->handle, &dcb)) { + goto getStateFailed; + } + dcb.XonLim = (WORD) (infoPtr->sysBufRead*1/2); + dcb.XoffLim = (WORD) (infoPtr->sysBufRead*1/4); + if (!SetCommState(infoPtr->handle, &dcb)) { + goto setStateFailed; + } + return TCL_OK; + } + + /* + * Option -pollinterval msec + */ + + if ((len > 1) && (strncmp(optionName, "-pollinterval", len) == 0)) { + if (Tcl_GetInt(interp, value, &(infoPtr->blockTime)) != TCL_OK) { + return TCL_ERROR; + } + return TCL_OK; + } + + /* + * Option -timeout msec + */ + + if ((len > 2) && (strncmp(optionName, "-timeout", len) == 0)) { + int msec; + COMMTIMEOUTS tout = {0,0,0,0,0}; + + if (Tcl_GetInt(interp, value, &msec) != TCL_OK) { + return TCL_ERROR; + } + tout.ReadTotalTimeoutConstant = msec; + if (!SetCommTimeouts(infoPtr->handle, &tout)) { + if (interp != NULL) { + TclWinConvertError(GetLastError()); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't set comm timeouts: %s", + Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + + return TCL_OK; + } + + 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; +} + +/* + *---------------------------------------------------------------------- + * + * SerialGetOptionProc -- + * + * Gets a mode associated with an IO channel. If the optionName arg is + * non NULL, retrieves the value of that option. If the optionName arg is + * NULL, retrieves a list of alternating option names and values for the + * given channel. + * + * Results: + * A standard Tcl result. Also sets the supplied DString to the string + * value of the option(s) returned. + * + * Side effects: + * The string returned by this function is in static storage and may be + * reused at any time subsequent to the call. + * + *---------------------------------------------------------------------- + */ + +static int +SerialGetOptionProc( + ClientData instanceData, /* File state. */ + Tcl_Interp *interp, /* For error reporting - can be NULL. */ + const char *optionName, /* Option to get. */ + Tcl_DString *dsPtr) /* Where to store value(s). */ +{ + SerialInfo *infoPtr; + DCB dcb; + size_t len; + int valid = 0; /* Flag if valid option parsed. */ + + infoPtr = (SerialInfo *) instanceData; + + if (optionName == NULL) { + len = 0; + } else { + len = strlen(optionName); + } + + /* + * Get option -mode + */ + + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-mode"); + } + if (len==0 || (len>2 && (strncmp(optionName, "-mode", len) == 0))) { + char parity; + const char *stop; + char buf[2 * TCL_INTEGER_SPACE + 16]; + + if (!GetCommState(infoPtr->handle, &dcb)) { + if (interp != NULL) { + TclWinConvertError(GetLastError()); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get comm state: %s", Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + + valid = 1; + parity = 'n'; + if (dcb.Parity <= 4) { + parity = "noems"[dcb.Parity]; + } + stop = (dcb.StopBits == ONESTOPBIT) ? "1" : + (dcb.StopBits == ONE5STOPBITS) ? "1.5" : "2"; + + wsprintfA(buf, "%d,%c,%d,%s", dcb.BaudRate, parity, + dcb.ByteSize, stop); + Tcl_DStringAppendElement(dsPtr, buf); + } + + /* + * Get option -pollinterval + */ + + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-pollinterval"); + } + if (len==0 || (len>1 && strncmp(optionName, "-pollinterval", len)==0)) { + char buf[TCL_INTEGER_SPACE + 1]; + + valid = 1; + wsprintfA(buf, "%d", infoPtr->blockTime); + Tcl_DStringAppendElement(dsPtr, buf); + } + + /* + * Get option -sysbuffer + */ + + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-sysbuffer"); + Tcl_DStringStartSublist(dsPtr); + } + if (len==0 || (len>1 && strncmp(optionName, "-sysbuffer", len) == 0)) { + char buf[TCL_INTEGER_SPACE + 1]; + valid = 1; + + wsprintfA(buf, "%d", infoPtr->sysBufRead); + Tcl_DStringAppendElement(dsPtr, buf); + wsprintfA(buf, "%d", infoPtr->sysBufWrite); + Tcl_DStringAppendElement(dsPtr, buf); + } + if (len == 0) { + Tcl_DStringEndSublist(dsPtr); + } + + /* + * Get option -xchar + */ + + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-xchar"); + Tcl_DStringStartSublist(dsPtr); + } + if (len==0 || (len>1 && strncmp(optionName, "-xchar", len) == 0)) { + char buf[4]; + valid = 1; + + if (!GetCommState(infoPtr->handle, &dcb)) { + if (interp != NULL) { + TclWinConvertError(GetLastError()); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get comm state: %s", Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + sprintf(buf, "%c", dcb.XonChar); + Tcl_DStringAppendElement(dsPtr, buf); + sprintf(buf, "%c", dcb.XoffChar); + Tcl_DStringAppendElement(dsPtr, buf); + } + if (len == 0) { + Tcl_DStringEndSublist(dsPtr); + } + + /* + * Get option -lasterror + * + * Option is readonly and returned by [fconfigure chan -lasterror] but not + * returned by unnamed [fconfigure chan]. + */ + + if (len>1 && strncmp(optionName, "-lasterror", len)==0) { + valid = 1; + SerialErrorStr(infoPtr->lastError, dsPtr); + } + + /* + * get option -queue + * + * Option is readonly and returned by [fconfigure chan -queue]. + */ + + if (len>1 && strncmp(optionName, "-queue", len)==0) { + char buf[TCL_INTEGER_SPACE + 1]; + COMSTAT cStat; + DWORD error; + int inBuffered, outBuffered, count; + + valid = 1; + + /* + * Query the pending data in Tcl's internal queues. + */ + + inBuffered = Tcl_InputBuffered(infoPtr->channel); + outBuffered = Tcl_OutputBuffered(infoPtr->channel); + + /* + * Query the number of bytes in our output queue: + * 1. The bytes pending in the output thread + * 2. The bytes in the system drivers buffer + * The writer thread should not interfere this action. + */ + + EnterCriticalSection(&infoPtr->csWrite); + ClearCommError(infoPtr->handle, &error, &cStat); + count = (int) cStat.cbOutQue + infoPtr->writeQueue; + LeaveCriticalSection(&infoPtr->csWrite); + + wsprintfA(buf, "%d", inBuffered + cStat.cbInQue); + Tcl_DStringAppendElement(dsPtr, buf); + wsprintfA(buf, "%d", outBuffered + count); + Tcl_DStringAppendElement(dsPtr, buf); + } + + /* + * get option -ttystatus + * + * Option is readonly and returned by [fconfigure chan -ttystatus] but not + * returned by unnamed [fconfigure chan]. + */ + + if (len>4 && strncmp(optionName, "-ttystatus", len)==0) { + DWORD status; + + if (!GetCommModemStatus(infoPtr->handle, &status)) { + if (interp != NULL) { + TclWinConvertError(GetLastError()); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get tty status: %s", Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + valid = 1; + SerialModemStatusStr(status, dsPtr); + } + + if (valid) { + return TCL_OK; + } + return Tcl_BadChannelOption(interp, optionName, + "mode pollinterval lasterror queue sysbuffer ttystatus xchar"); +} + +/* + *---------------------------------------------------------------------- + * + * SerialThreadActionProc -- + * + * Insert or remove any thread local refs to this channel. + * + * Results: + * None. + * + * Side effects: + * Changes thread local list of valid channels. + * + *---------------------------------------------------------------------- + */ + +static void +SerialThreadActionProc( + ClientData instanceData, + int action) +{ + SerialInfo *infoPtr = (SerialInfo *) instanceData; + + /* + * We do not access firstSerialPtr 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. + */ + + Tcl_MutexLock(&serialMutex); + if (action == TCL_CHANNEL_THREAD_INSERT) { + /* + * We can't copy the thread information from the channel when the + * channel is created. At this time the channel back pointer has not + * been set yet. However in that case the threadId has already been + * set by TclpCreateCommandChannel itself, so the structure is still + * good. + */ + + SerialInit(); + if (infoPtr->channel != NULL) { + infoPtr->threadId = Tcl_GetChannelThread(infoPtr->channel); + } + } else { + infoPtr->threadId = NULL; + } + Tcl_MutexUnlock(&serialMutex); +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/win/tclWinSock.c b/win/tclWinSock.c new file mode 100644 index 0000000..ee6be96 --- /dev/null +++ b/win/tclWinSock.c @@ -0,0 +1,3565 @@ +/* + * tclWinSock.c -- + * + * This file contains Windows-specific socket related code. + * + * Copyright (c) 1995-1997 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution of + * 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. + * + * - Each Tcl-thread with its sockets maintains an internal window to receive + * socket messages from the OS. + * + * - To ensure that message reception is always running this window is + * actually owned and handled by an internal thread. This we call the + * co-thread of Tcl's thread. + * + * - The whole structure is set up by InitSockets() which is called for each + * Tcl thread. The implementation of the co-thread is in SocketThread(), + * and the messages are handled by SocketProc(). The connection between + * both is not directly visible, it is done through a Win32 window class. + * This class is initialized by InitSockets() as well, and used in the + * creation of the message receiver windows. + * + * - An important thing to note is that *both* thread and co-thread have + * access to the list of sockets maintained in the private TSD data of the + * thread. The co-thread was given access to it upon creation through the + * new thread's client-data. + * + * Because of this dual access the TSD data contains an OS mutex, the + * "socketListLock", to mediate exclusion between thread and co-thread. + * + * The co-thread's access is all in SocketProc(). The thread's access is + * through SocketEventProc() (1) and the functions called by it. + * + * (Ad 1) This is the handler function for all queued socket events, which + * all the OS messages are translated to through the EventSource (2) + * driven by the OS messages. + * + * (Ad 2) The main functions for this are SocketSetupProc() and + * SocketCheckProc(). + */ + +#include "tclWinInt.h" + +#ifdef _MSC_VER +# pragma comment (lib, "ws2_32") +#endif + +/* + * Support for control over sockets' KEEPALIVE and NODELAY behavior is + * currently disabled. + */ + +#undef TCL_FEATURE_KEEPALIVE_NAGLE + +/* + * 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)) +#define GOT_BITS(var, bits) (((var) & (bits)) != 0) + +/* "sock" + a pointer in hex + \0 */ +#define SOCK_CHAN_LENGTH (4 + sizeof(void *) * 2 + 1) +#define SOCK_TEMPLATE "sock%p" + +/* + * The following variable is used to tell whether this module has been + * initialized. If 1, initialization of sockets was successful, if -1 then + * socket initialization failed (WSAStartup failed). + */ + +static int initialized = 0; +static const TCHAR className[] = TEXT("TclSocket"); +TCL_DECLARE_MUTEX(socketMutex) + +/* + * The following defines declare the messages used on socket windows. + */ + +#define SOCKET_MESSAGE WM_USER+1 +#define SOCKET_SELECT WM_USER+2 +#define SOCKET_TERMINATE WM_USER+3 +#define SELECT TRUE +#define UNSELECT FALSE + +/* + * This is needed to comply with the strict aliasing rules of GCC, but it also + * simplifies casting between the different sockaddr types. + */ + +typedef union { + struct sockaddr sa; + struct sockaddr_in sa4; + struct sockaddr_in6 sa6; + struct sockaddr_storage sas; +} address; + +#ifndef IN6_ARE_ADDR_EQUAL +#define IN6_ARE_ADDR_EQUAL IN6_ADDR_EQUAL +#endif + +/* + * This structure describes per-instance state of a tcp based channel. + */ + +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. */ + int testFlags; /* bit field for tests. Is set by testsocket + * test procedure */ + 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. + * 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. + * 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. */ + + /* + * 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. */ +}; + +/* + * 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 */ + +/* + * These bits may be ORed together into the "testFlags" field of a TcpState + * structure. + */ + +#define TCP_ASYNC_TEST_MODE (1<<0) /* Async testing activated. Do not + * automatically continue connection + * process */ + +/* + * The following structure is what is added to the Tcl event queue when a + * socket event occurs. + */ + +typedef struct { + Tcl_Event header; /* Information that is standard for all + * events. */ + SOCKET socket; /* Socket descriptor that is ready. Used to + * find the TcpState structure for the file + * (can't point directly to the TcpState + * structure because it could go away while + * the event is queued). */ +} SocketEvent; + +/* + * This defines the minimum buffersize maintained by the kernel. + */ + +#define TCP_BUFFER_SIZE 4096 + + +typedef struct { + HWND hwnd; /* Handle to window for socket messages. */ + HANDLE socketThread; /* Thread handling the window */ + Tcl_ThreadId threadId; /* Parent thread. */ + HANDLE readyEvent; /* Event indicating that a socket event is + * ready. Also used to indicate that the + * socketThread has been initialized and has + * started. */ + HANDLE socketListLock; /* Win32 Event to lock the socketList */ + TcpState *pendingTcpState; + /* This socket is opened but not jet in the + * list. This value is also checked by + * the event structure. */ + TcpState *socketList; /* Every open socket in this thread has an + * entry on this list. */ +} ThreadSpecificData; + +static Tcl_ThreadDataKey dataKey; +static WNDCLASS windowClass; + +/* + * Static routines for this file: + */ + +static int TcpConnect(Tcl_Interp *interp, + TcpState *state); +static void InitSockets(void); +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(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); + +static Tcl_EventCheckProc SocketCheckProc; +static Tcl_EventProc SocketEventProc; +static Tcl_EventSetupProc SocketSetupProc; +static Tcl_DriverBlockModeProc TcpBlockModeProc; +static Tcl_DriverCloseProc TcpCloseProc; +static Tcl_DriverClose2Proc TcpClose2Proc; +static Tcl_DriverSetOptionProc TcpSetOptionProc; +static Tcl_DriverGetOptionProc TcpGetOptionProc; +static Tcl_DriverInputProc TcpInputProc; +static Tcl_DriverOutputProc TcpOutputProc; +static Tcl_DriverWatchProc TcpWatchProc; +static Tcl_DriverGetHandleProc TcpGetHandleProc; + +/* + * This structure describes the channel type structure for TCP socket + * based IO: + */ + +static const Tcl_ChannelType tcpChannelType = { + "tcp", /* Type name. */ + TCL_CHANNEL_VERSION_5, /* v5 channel */ + TcpCloseProc, /* Close proc. */ + TcpInputProc, /* Input proc. */ + TcpOutputProc, /* Output proc. */ + NULL, /* Seek proc. */ + TcpSetOptionProc, /* Set option proc. */ + TcpGetOptionProc, /* Get option proc. */ + TcpWatchProc, /* Initialize notifier. */ + TcpGetHandleProc, /* Get OS handles out of channel. */ + TcpClose2Proc, /* Close2 proc. */ + TcpBlockModeProc, /* Set blocking or non-blocking mode.*/ + NULL, /* flush proc. */ + NULL, /* handler proc. */ + NULL, /* wide seek proc. */ + TcpThreadActionProc, /* thread action proc. */ + NULL /* truncate proc. */ +}; + +/* + * The following variable holds the network name of this host. + */ + +static TclInitProcessGlobalValueProc InitializeHostName; +static ProcessGlobalValue hostName = + {0, 0, NULL, NULL, InitializeHostName, NULL, NULL}; + +/* + * Simple wrapper round the SendMessage syscall. + */ + +#define SendSelectMessage(tsdPtr, message, payload) \ + SendMessage((tsdPtr)->hwnd, SOCKET_SELECT, \ + (WPARAM) (message), (LPARAM) (payload)) + + +/* + * Address print debug functions + */ +#if 0 +void +printaddrinfo( + struct addrinfo *ai, + char *prefix) +{ + char host[NI_MAXHOST], port[NI_MAXSERV]; + + getnameinfo(ai->ai_addr, ai->ai_addrlen, + host, sizeof(host), port, sizeof(port), + NI_NUMERICHOST|NI_NUMERICSERV); +} + +void +printaddrinfolist( + struct addrinfo *addrlist, + char *prefix) +{ + struct addrinfo *ai; + + for (ai = addrlist; ai != NULL; ai = ai->ai_next) { + printaddrinfo(ai, prefix); + } +} +#endif + +/* + *---------------------------------------------------------------------- + * + * InitializeHostName -- + * + * 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, + size_t *lengthPtr, + Tcl_Encoding *encodingPtr) +{ + TCHAR tbuf[MAX_COMPUTERNAME_LENGTH + 1]; + DWORD length = MAX_COMPUTERNAME_LENGTH + 1; + Tcl_DString ds; + + if (GetComputerName(tbuf, &length) != 0) { + /* + * Convert string from native to UTF then change to lowercase. + */ + + Tcl_UtfToLower(Tcl_WinTCharToUtf(tbuf, -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); + } + } + + *encodingPtr = Tcl_GetEncoding(NULL, "utf-8"); + *lengthPtr = Tcl_DStringLength(&ds); + *valuePtr = ckalloc(*lengthPtr + 1); + memcpy(*valuePtr, Tcl_DStringValue(&ds), *lengthPtr + 1); + Tcl_DStringFree(&ds); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetHostName -- + * + * Returns the name of the local host. + * + * Results: + * A string containing the network name for this machine, or an empty + * string if we can't figure out the name. The caller must not modify or + * free this string. + * + * Side effects: + * Caches the name to return for future calls. + * + *---------------------------------------------------------------------- + */ + +const char * +Tcl_GetHostName(void) +{ + return Tcl_GetString(TclGetProcessGlobalValue(&hostName)); +} + +/* + *---------------------------------------------------------------------- + * + * TclpHasSockets -- + * + * 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: + * Returns TCL_OK if the system supports sockets, or TCL_ERROR with an + * error in interp (if non-NULL). + * + * 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. + * + *---------------------------------------------------------------------- + */ + +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); + 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; +} + +/* + *---------------------------------------------------------------------- + * + * TclpFinalizeSockets -- + * + * This function is called from Tcl_FinalizeThread to finalize the + * platform specific socket subsystem. Also, it may be called from within + * this module to cleanup the state if unable to initialize the sockets + * subsystem. + * + * Results: + * None. + * + * Side effects: + * Deletes the event source and destroys the socket thread. + * + *---------------------------------------------------------------------- + */ + +void +TclpFinalizeSockets(void) +{ + ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + + /* + * Careful! This is a finalizer! + */ + + if (tsdPtr == NULL) { + return; + } + + if (tsdPtr->socketThread != NULL) { + if (tsdPtr->hwnd != NULL) { + PostMessage(tsdPtr->hwnd, SOCKET_TERMINATE, 0, 0); + + /* + * Wait for the thread to exit. This ensures that we are + * completely cleaned up before we leave this function. + */ + + 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; + } + Tcl_DeleteEventSource(SocketSetupProc, SocketCheckProc, NULL); +} + +/* + *---------------------------------------------------------------------- + * + * TcpBlockModeProc -- + * + * This function is invoked by the generic IO level to set blocking and + * nonblocking mode on a TCP socket based channel. + * + * Results: + * 0 if successful, errno when failed. + * + * Side effects: + * Sets the device into blocking or nonblocking mode. + * + *---------------------------------------------------------------------- + */ + + /* 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. */ +{ + TcpState *statePtr = instanceData; + + if (mode == TCL_MODE_NONBLOCKING) { + SET_BITS(statePtr->flags, TCP_NONBLOCKING); + } else { + CLEAR_BITS(statePtr->flags, TCP_NONBLOCKING); + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * WaitForConnect -- + * + * Check the state of an async connect process. If a connection attempt + * terminated, process it, which may finalize it or may start the next + * attempt. If a connect error occures, it is saved in + * statePtr->connectError to be reported by 'fconfigure -error'. + * + * 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: + * 0 if the connection has completed, -1 if still in progress or there is + * an error. + * + * Side effects: + * Processes socket events off the system queue. May process + * asynchroneous connect. + * + *---------------------------------------------------------------------- + */ + +static int +WaitForConnect( + TcpState *statePtr, /* State of the socket. */ + int *errorCodePtr) /* Where to store errors? A passed + * null-pointer activates background mode. */ +{ + int result; + int oldMode; + ThreadSpecificData *tsdPtr; + + /* + * Check if an async connect failed already and error reporting is + * demanded, return the error ENOTCONN. + */ + + if (errorCodePtr != NULL && GOT_BITS(statePtr->flags, TCP_ASYNC_FAILED)) { + *errorCodePtr = ENOTCONN; + return -1; + } + + /* + * Check if an async connect is running. If not return ok + */ + + if (!GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) { + return 0; + } + + /* + * In socket test mode do not continue with the connect + * Exceptions are: + * - Call by recv/send and blocking socket + * (errorCodePtr != NULL && !GOT_BITS(flags, TCP_NONBLOCKING)) + * - Call by the event queue (errorCodePtr == NULL) + */ + + if (GOT_BITS(statePtr->testFlags, TCP_ASYNC_TEST_MODE) + && errorCodePtr != NULL + && GOT_BITS(statePtr->flags, TCP_NONBLOCKING)) { + *errorCodePtr = EWOULDBLOCK; + return -1; + } + + /* + * Be sure to disable event servicing so we are truly modal. + */ + + oldMode = Tcl_SetServiceMode(TCL_SERVICE_NONE); + + /* + * Loop in the blocking case until the connect signal is present + */ + + while (1) { + /* + * Get the statePtr lock. + */ + + tsdPtr = TclThreadDataKeyGet(&dataKey); + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + + /* + * Check for connect event. + */ + + if (GOT_BITS(statePtr->readyEvents, FD_CONNECT)) { + /* + * Consume the connect event. + */ + + CLEAR_BITS(statePtr->readyEvents, FD_CONNECT); + + /* + * For blocking sockets and foreground processing, disable async + * connect as we continue now synchoneously. + */ + + if (errorCodePtr != NULL && + !GOT_BITS(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 (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) { + if (errorCodePtr != NULL) { + *errorCodePtr = EWOULDBLOCK; + } + return -1; + } + return 0; + } + + /* + * Connect finally failed. For foreground operation return + * ENOTCONN. + */ + + if (errorCodePtr != NULL) { + *errorCodePtr = ENOTCONN; + } + return -1; + } + + /* + * Free list lock. + */ + + SetEvent(tsdPtr->socketListLock); + + /* + * Background operation returns with no action as there was no connect + * event + */ + + if (errorCodePtr == NULL) { + return -1; + } + + /* + * A non blocking socket waiting for an asyncronous connect returns + * directly the error EWOULDBLOCK. + */ + + if (GOT_BITS(statePtr->flags, TCP_NONBLOCKING)) { + *errorCodePtr = EWOULDBLOCK; + return -1; + } + + /* + * Wait until something happens. + */ + + WaitForSingleObject(tsdPtr->readyEvent, INFINITE); + } +} + +/* + *---------------------------------------------------------------------- + * + * TcpInputProc -- + * + * This function is invoked by the generic IO level to read input from a + * TCP socket based channel. + * + * Results: + * The number of bytes read is returned or -1 on error. An output + * argument contains the POSIX error code on error, or zero if no error + * occurred. + * + * Side effects: + * Reads input from the input device of the channel. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TcpInputProc( + ClientData instanceData, /* Socket state. */ + char *buf, /* Where to store data read. */ + int bufSize, /* How much space is available in the + * buffer? */ + int *errorCodePtr) /* Where to store error code. */ +{ + TcpState *statePtr = instanceData; + int bytesRead; + DWORD error; + ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + + *errorCodePtr = 0; + + /* + * Check that WinSock is initialized; do not call it if not, to prevent + * system crashes. This can happen at exit time if the exit handler for + * WinSock ran before other exit handlers that want to use sockets. + */ + + if (!SocketsEnabled()) { + *errorCodePtr = EFAULT; + return -1; + } + + /* + * First check to see if EOF was already detected, to prevent calling the + * socket stack after the first time EOF is detected. + */ + + if (GOT_BITS(statePtr->flags, SOCKET_EOF)) { + 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; + } + + /* + * 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. + */ + + while (1) { + SendSelectMessage(tsdPtr, UNSELECT, statePtr); + + /* + * Single fd operation: this proc is only called for a connected + * socket. + */ + + bytesRead = recv(statePtr->sockets->fd, buf, bufSize, 0); + CLEAR_BITS(statePtr->readyEvents, FD_READ); + + /* + * Check for end-of-file condition or successful read. + */ + + if (bytesRead == 0) { + SET_BITS(statePtr->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 (GOT_BITS(statePtr->readyEvents, FD_CLOSE)) { + SET_BITS(statePtr->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) { + SET_BITS(statePtr->flags, SOCKET_EOF); + bytesRead = 0; + break; + } + + /* + * Check for error condition or underflow in non-blocking case. + */ + + if (GOT_BITS(statePtr->flags, TCP_NONBLOCKING) + || (error != WSAEWOULDBLOCK)) { + TclWinConvertError(error); + *errorCodePtr = Tcl_GetErrno(); + bytesRead = -1; + break; + } + + /* + * In the blocking case, wait until the file becomes readable or + * closed and try again. + */ + + if (!WaitForSocketEvent(statePtr, FD_READ|FD_CLOSE, errorCodePtr)) { + bytesRead = -1; + break; + } + } + + SendSelectMessage(tsdPtr, SELECT, statePtr); + + return bytesRead; +} + +/* + *---------------------------------------------------------------------- + * + * TcpOutputProc -- + * + * This function is called by the generic IO level to write data to a + * socket based channel. + * + * Results: + * The number of bytes written or -1 on failure. + * + * Side effects: + * Produces output on the socket. + * + *---------------------------------------------------------------------- + */ + +static int +TcpOutputProc( + ClientData instanceData, /* Socket state. */ + const char *buf, /* The data buffer. */ + int toWrite, /* How many bytes to write? */ + int *errorCodePtr) /* Where to store error code. */ +{ + TcpState *statePtr = instanceData; + int written; + DWORD error; + ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + + *errorCodePtr = 0; + + /* + * Check that WinSock is initialized; do not call it if not, to prevent + * system crashes. This can happen at exit time if the exit handler for + * WinSock ran before other exit handlers that want to use sockets. + */ + + if (!SocketsEnabled()) { + *errorCodePtr = EFAULT; + return -1; + } + + /* + * Check if there is an async connect running. + * For blocking sockets terminate connect, otherwise do one step. + * For a non blocking socket return EWOULDBLOCK if connect not terminated + */ + + if (WaitForConnect(statePtr, errorCodePtr) != 0) { + return -1; + } + + while (1) { + SendSelectMessage(tsdPtr, UNSELECT, 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 (GOT_BITS(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) { + CLEAR_BITS(statePtr->readyEvents, FD_WRITE); + if (GOT_BITS(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; + } + } + + SendSelectMessage(tsdPtr, SELECT, statePtr); + + return written; +} + +/* + *---------------------------------------------------------------------- + * + * TcpCloseProc -- + * + * This function is called by the generic IO level to perform channel + * type specific cleanup on a socket based channel when the channel is + * closed. + * + * Results: + * 0 if successful, the value of errno if failed. + * + * Side effects: + * Closes the socket. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TcpCloseProc( + ClientData instanceData, /* The socket to close. */ + Tcl_Interp *interp) /* Unused. */ +{ + TcpState *statePtr = instanceData; + /* TIP #218 */ + int errorCode = 0; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + /* + * 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()) { + /* + * Clean up the OS socket handle. The default Windows setting for a + * socket is SO_DONTLINGER, which does a graceful shutdown in the + * background. + */ + + while (statePtr->sockets != NULL) { + TcpFdList *thisfd = statePtr->sockets; + + statePtr->sockets = thisfd->next; + if (closesocket(thisfd->fd) == SOCKET_ERROR) { + TclWinConvertError((DWORD) WSAGetLastError()); + errorCode = Tcl_GetErrno(); + } + ckfree(thisfd); + } + } + + if (statePtr->addrlist != NULL) { + freeaddrinfo(statePtr->addrlist); + } + if (statePtr->myaddrlist != NULL) { + freeaddrinfo(statePtr->myaddrlist); + } + + /* + * Clear an eventual tsd info list pointer. + * + * This may be called, if an async socket connect fails or is closed + * between connect and thread action callback. + */ + + if (tsdPtr->pendingTcpState != NULL + && tsdPtr->pendingTcpState == statePtr) { + /* + * Get infoPtr lock, because this concerns the notifier thread. + */ + + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + + tsdPtr->pendingTcpState = NULL; + + /* + * Free list lock. + */ + + SetEvent(tsdPtr->socketListLock); + } + + /* + * TIP #218. Removed the code removing the structure from the global + * socket list. This is now done by the thread action callbacks, and only + * there. This happens before this code is called. We can free without + * fear of damaging the list. + */ + + ckfree(statePtr); + return errorCode; +} + +/* + *---------------------------------------------------------------------- + * + * TcpClose2Proc -- + * + * This function is called by the generic IO level to perform the channel + * type specific part of a half-close: namely, a shutdown() on a socket. + * + * Results: + * 0 if successful, the value of errno if failed. + * + * Side effects: + * Shuts down one side of the socket. + * + *---------------------------------------------------------------------- + */ + +static int +TcpClose2Proc( + ClientData instanceData, /* The socket to close. */ + Tcl_Interp *interp, /* For error reporting. */ + int flags) /* Flags that indicate which side to close. */ +{ + TcpState *statePtr = instanceData; + int errorCode = 0; + int sd; + + /* + * Shutdown the OS socket handle. + */ + + switch(flags) { + case TCL_CLOSE_READ: + sd = SD_RECEIVE; + break; + case TCL_CLOSE_WRITE: + sd = SD_SEND; + break; + default: + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "socket close2proc called bidirectionally", -1)); + } + return TCL_ERROR; + } + + /* + * Single fd operation: Tcl_OpenTcpServer() does not set TCL_READABLE or + * TCL_WRITABLE so this should never be called for a server socket. + */ + + if (shutdown(statePtr->sockets->fd, sd) == SOCKET_ERROR) { + TclWinConvertError((DWORD) WSAGetLastError()); + errorCode = Tcl_GetErrno(); + } + + return errorCode; +} + +/* + *---------------------------------------------------------------------- + * + * TcpSetOptionProc -- + * + * Sets Tcp channel specific options. + * + * Results: + * None, unless an error happens. + * + * Side effects: + * Changes attributes of the socket at the system level. + * + *---------------------------------------------------------------------- + */ + +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. */ +{ +#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 + * 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()) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "winsock is not initialized", -1)); + } + return TCL_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; + + 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" + + /* + * 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()) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "winsock is not initialized", -1)); + } + return TCL_ERROR; + } + + /* + * Go one step in async connect + * + * If any error is thrown save it as backround error to report eventually + * below. + */ + + if (!GOT_BITS(statePtr->testFlags, TCP_ASYNC_TEST_MODE)) { + WaitForConnect(statePtr, NULL); + } + + sock = statePtr->sockets->fd; + if (optionName != NULL) { + len = strlen(optionName); + } + + if ((len > 1) && (optionName[1] == 'e') && + (strncmp(optionName, "-error", len) == 0)) { + /* + * Do not return any errors if async connect is running. + */ + + if (!GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) { + if (GOT_BITS(statePtr->flags, TCP_ASYNC_FAILED)) { + /* + * 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. + */ + + if (statePtr->connectError != 0) { + Tcl_DStringAppend(dsPtr, + Tcl_ErrnoMsg(statePtr->connectError), -1); + statePtr->connectError = 0; + } + } else { + /* + * Report an eventual last error of the socket system. + */ + + int optlen; + int ret; + DWORD err; + + /* + * Populate the err variable with a POSIX 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; + } + + if ((len > 1) && (optionName[1] == 'c') && + (strncmp(optionName, "-connecting", len) == 0)) { + Tcl_DStringAppend(dsPtr, + GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING) + ? "1" : "0", -1); + return TCL_OK; + } + + if (interp != NULL + && Tcl_GetVar2(interp, SUPPRESS_RDNS_VAR, NULL, 0) != NULL) { + reverseDNS = NI_NUMERICHOST; + } + + if ((len == 0) || ((len > 1) && (optionName[1] == 'p') && + (strncmp(optionName, "-peername", len) == 0))) { + address peername; + socklen_t size = sizeof(peername); + + if (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) { + /* + * In async connect output an empty string + */ + + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-peername"); + Tcl_DStringAppendElement(dsPtr, ""); + } else { + return TCL_OK; + } + } else if (getpeername(sock, (LPSOCKADDR) &(peername.sa), + &size) == 0) { + /* + * Peername fetch succeeded - output list + */ + + 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 { + /* + * 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} + */ + + if (len) { + TclWinConvertError((DWORD) WSAGetLastError()); + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get peername: %s", + Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + } + } + + if ((len == 0) || ((len > 1) && (optionName[1] == 's') && + (strncmp(optionName, "-sockname", len) == 0))) { + TcpFdList *fds; + address sockname; + socklen_t size; + int found = 0; + + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-sockname"); + Tcl_DStringStartSublist(dsPtr); + } + if (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) { + /* + * 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; + + found = 1; + getnameinfo(&sockname.sa, size, host, sizeof(host), + NULL, 0, NI_NUMERICHOST); + Tcl_DStringAppendElement(dsPtr, host); + + /* + * We don't want to resolve INADDR_ANY and sin6addr_any; + * they can sometimes cause problems (and never have a + * name). + */ + + flags |= NI_NUMERICSERV; + if (sockname.sa.sa_family == AF_INET) { + if (sockname.sa4.sin_addr.s_addr == INADDR_ANY) { + flags |= NI_NUMERICHOST; + } + } else if (sockname.sa.sa_family == AF_INET6) { + if ((IN6_ARE_ADDR_EQUAL(&sockname.sa6.sin6_addr, + &in6addr_any)) || + (IN6_IS_ADDR_V4MAPPED(&sockname.sa6.sin6_addr) + && sockname.sa6.sin6_addr.s6_addr[12] == 0 + && sockname.sa6.sin6_addr.s6_addr[13] == 0 + && sockname.sa6.sin6_addr.s6_addr[14] == 0 + && sockname.sa6.sin6_addr.s6_addr[15] == 0)) { + flags |= NI_NUMERICHOST; + } + } + getnameinfo(&sockname.sa, size, host, sizeof(host), + port, sizeof(port), flags); + Tcl_DStringAppendElement(dsPtr, host); + Tcl_DStringAppendElement(dsPtr, port); + } + } + } + if (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; + } + } + +#ifdef TCL_FEATURE_KEEPALIVE_NAGLE + if (len == 0 || !strncmp(optionName, "-keepalive", len)) { + int optlen; + BOOL opt = FALSE; + + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-keepalive"); + } + optlen = sizeof(BOOL); + getsockopt(sock, SOL_SOCKET, SO_KEEPALIVE, (char *)&opt, &optlen); + if (opt) { + Tcl_DStringAppendElement(dsPtr, "1"); + } else { + Tcl_DStringAppendElement(dsPtr, "0"); + } + if (len > 0) { + return TCL_OK; + } + } + + if (len == 0 || !strncmp(optionName, "-nagle", len)) { + int optlen; + BOOL opt = FALSE; + + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-nagle"); + } + optlen = sizeof(BOOL); + getsockopt(sock, IPPROTO_TCP, TCP_NODELAY, (char *)&opt, &optlen); + if (opt) { + Tcl_DStringAppendElement(dsPtr, "0"); + } else { + Tcl_DStringAppendElement(dsPtr, "1"); + } + if (len > 0) { + return TCL_OK; + } + } +#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/ + + 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 TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TcpWatchProc -- + * + * Informs the channel driver of the events that the generic channel code + * wishes to receive on this socket. + * + * Results: + * None. + * + * Side effects: + * May cause the notifier to poll if any of the specified conditions are + * already true. + * + *---------------------------------------------------------------------- + */ + +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. */ +{ + TcpState *statePtr = instanceData; + + /* + * Update the watch events mask. Only if the socket is not a server + * socket. [Bug 557878] + */ + + if (!statePtr->acceptProc) { + statePtr->watchEvents = 0; + if (GOT_BITS(mask, TCL_READABLE)) { + SET_BITS(statePtr->watchEvents, FD_READ | FD_CLOSE); + } + if (GOT_BITS(mask, TCL_WRITABLE)) { + SET_BITS(statePtr->watchEvents, FD_WRITE | FD_CLOSE); + } + + /* + * If there are any conditions already set, then tell the notifier to + * poll rather than block. + */ + + if (statePtr->readyEvents & statePtr->watchEvents) { + Tcl_Time blockTime = { 0, 0 }; + + 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. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TcpGetHandleProc( + ClientData instanceData, /* The socket state. */ + int direction, /* Not used. */ + ClientData *handlePtr) /* Where to store the handle. */ +{ + TcpState *statePtr = instanceData; + + *handlePtr = INT2PTR(statePtr->sockets->fd); + return TCL_OK; +} + + + +/* + *---------------------------------------------------------------------- + * + * TcpConnect -- + * + * This function opens a new socket in client mode. + * + * This might be called in 3 circumstances: + * - By a regular socket command + * - By the event handler to continue an asynchroneous connect + * - By a blocking socket function (gets/puts) to terminate the + * connect synchroneously + * + * Results: + * 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: + * Opens a socket. + * + * Remarks: + * A single host name may resolve to more than one IP address, e.g. for + * an IPv4/IPv6 dual stack host. For handling asyncronously connecting + * sockets in the background for such hosts, this function can act as a + * coroutine. On the first call, it sets up the control variables for the + * two nested loops over the local and remote addresses. Once the first + * connection attempt is in progress, it sets up itself as a writable + * event handler for that socket, and returns. When the callback occurs, + * control is transferred to the "reenter" label, right after the initial + * return and the loops resume as if they had never been interrupted. + * For syncronously connecting sockets, the loops work the usual way. + * + *---------------------------------------------------------------------- + */ + +static int +TcpConnect( + Tcl_Interp *interp, /* For error reporting; can be NULL. */ + TcpState *statePtr) +{ + DWORD error; + int async_connect = GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT); + /* We are started with async connect and the + * connect notification was not yet + * received. */ + int async_callback = GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING); + /* We were called by the event procedure and + * continue our loop. */ + ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + + if (async_callback) { + goto reenter; + } + + for (statePtr->addr = statePtr->addrlist; statePtr->addr != NULL; + statePtr->addr = statePtr->addr->ai_next) { + for (statePtr->myaddr = statePtr->myaddrlist; + statePtr->myaddr != NULL; + statePtr->myaddr = statePtr->myaddr->ai_next) { + /* + * No need to try combinations of local and remote addresses + * of different families. + */ + + if (statePtr->myaddr->ai_family != statePtr->addr->ai_family) { + continue; + } + + /* + * Close the socket if it is still open from the last unsuccessful + * iteration. + */ + + if (statePtr->sockets->fd != INVALID_SOCKET) { + closesocket(statePtr->sockets->fd); + } + + /* + * Get statePtr lock. + */ + + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + + /* + * Reset last error from last try + */ + + statePtr->notifierConnectError = 0; + Tcl_SetErrno(0); + + statePtr->sockets->fd = socket(statePtr->myaddr->ai_family, + SOCK_STREAM, 0); + + /* + * Free list lock. + */ + + SetEvent(tsdPtr->socketListLock); + + /* + * Continue on socket creation error. + */ + + if (statePtr->sockets->fd == INVALID_SOCKET) { + TclWinConvertError((DWORD) WSAGetLastError()); + continue; + } + + /* + * Win-NT has a misfeature that sockets are inherited in child + * processes by default. Turn off the inherit bit. + */ + + SetHandleInformation((HANDLE) statePtr->sockets->fd, + HANDLE_FLAG_INHERIT, 0); + + /* + * Set kernel space buffering + */ + + TclSockMinimumBuffers((void *) statePtr->sockets->fd, + TCP_BUFFER_SIZE); + + /* + * Try to bind to a local port. + */ + + if (bind(statePtr->sockets->fd, statePtr->myaddr->ai_addr, + statePtr->myaddr->ai_addrlen) == SOCKET_ERROR) { + TclWinConvertError((DWORD) WSAGetLastError()); + continue; + } + + /* + * For asyncroneous connect set the socket in nonblocking mode + * and activate connect notification + */ + + if (async_connect) { + TcpState *statePtr2; + int in_socket_list = 0; + + /* + * Get statePtr lock. + */ + + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + + /* + * Bugfig for 336441ed59 to not ignore notifications until the + * infoPtr is in the list. + * Check if my statePtr is already in the tsdPtr->socketList + * It is set after this call by TcpThreadActionProc and is set + * on a second round. + * + * If not, we buffer my statePtr in the tsd memory so it is + * not lost by the event procedure + */ + + for (statePtr2 = tsdPtr->socketList; statePtr2 != NULL; + statePtr2 = statePtr2->nextPtr) { + if (statePtr2 == statePtr) { + in_socket_list = 1; + break; + } + } + if (!in_socket_list) { + tsdPtr->pendingTcpState = statePtr; + } + + /* + * Set connect mask to connect events + * + * This is activated by a SOCKET_SELECT message to the + * notifier thread. + */ + + SET_BITS(statePtr->selectEvents, FD_CONNECT); + + /* + * Free list lock. + */ + + SetEvent(tsdPtr->socketListLock); + + /* + * Activate accept notification. + */ + + SendSelectMessage(tsdPtr, SELECT, 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 + */ + + SET_BITS(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 + */ + + CLEAR_BITS(statePtr->flags, TCP_ASYNC_PENDING); + + /* + * Get statePtr lock. + */ + + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + + /* + * Get signaled connect error. + */ + + TclWinConvertError((DWORD) statePtr->notifierConnectError); + + /* + * Clear eventual connect flag. + */ + + CLEAR_BITS(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 asynchronously. + */ + + tsdPtr->pendingTcpState = NULL; + + if (Tcl_GetErrno() == 0) { + goto out; + } + } + } + + out: + /* + * Socket connected or connection failed + */ + + /* + * Async connect terminated + */ + + CLEAR_BITS(statePtr->flags, TCP_ASYNC_CONNECT); + + if (Tcl_GetErrno() == 0) { + /* + * Succesfully connected + * + * Set up the select mask for read/write events. + */ + + statePtr->selectEvents = FD_READ | FD_WRITE | FD_CLOSE; + + /* + * Register for interest in events in the select mask. Note that this + * automatically places the socket into non-blocking mode. + */ + + SendSelectMessage(tsdPtr, SELECT, 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. + */ + + SET_BITS(statePtr->readyEvents, FD_WRITE | FD_READ); + + /* + * Flag error to event routine. + */ + + SET_BITS(statePtr->flags, TCP_ASYNC_FAILED); + + /* + * Save connect error to be reported by 'fconfigure -error'. + */ + + statePtr->connectError = Tcl_GetErrno(); + + /* + * Free list lock. + */ + + SetEvent(tsdPtr->socketListLock); + } + + /* + * Error message on syncroneous connect + */ + + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open socket: %s", Tcl_PosixError(interp))); + } + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_OpenTcpClient -- + * + * Opens a TCP client socket and creates a channel around it. + * + * Results: + * The channel or NULL if failed. An error message is returned in the + * interpreter on failure. + * + * Side effects: + * Opens a client socket and creates a new channel. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_OpenTcpClient( + Tcl_Interp *interp, /* For error reporting; can be NULL. */ + int port, /* Port number to open. */ + const char *host, /* Host on which to open port. */ + const char *myaddr, /* Client-side address */ + int myport, /* Client-side port */ + int async) /* If nonzero, attempt to do an asynchronous + * connect. Otherwise we do a blocking + * connect. */ +{ + TcpState *statePtr; + const char *errorMsg = NULL; + struct addrinfo *addrlist = NULL, *myaddrlist = NULL; + char channelName[SOCK_CHAN_LENGTH]; + + if (TclpHasSockets(interp) != TCL_OK) { + return NULL; + } + + /* + * Check that WinSock is initialized; do not call it if not, to prevent + * system crashes. This can happen at exit time if the exit handler for + * WinSock ran before other exit handlers that want to use sockets. + */ + + if (!SocketsEnabled()) { + return NULL; + } + + /* + * Do the name lookups for the local and remote addresses. + */ + + if (!TclCreateSocketAddress(interp, &addrlist, host, port, 0, &errorMsg) + || !TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1, + &errorMsg)) { + if (addrlist != NULL) { + freeaddrinfo(addrlist); + } + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open socket: %s", errorMsg)); + } + return NULL; + } + + statePtr = NewSocketInfo(INVALID_SOCKET); + statePtr->addrlist = addrlist; + statePtr->myaddrlist = myaddrlist; + if (async) { + SET_BITS(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 statePtr->channel; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_MakeTcpClientChannel -- + * + * Creates a Tcl_Channel from an existing client TCP socket. + * + * Results: + * The Tcl_Channel wrapped around the preexisting TCP socket. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_MakeTcpClientChannel( + ClientData sock) /* The socket to wrap up into a channel. */ +{ + TcpState *statePtr; + char channelName[SOCK_CHAN_LENGTH]; + ThreadSpecificData *tsdPtr; + + if (TclpHasSockets(NULL) != TCL_OK) { + return NULL; + } + + tsdPtr = TclThreadDataKeyGet(&dataKey); + + /* + * Set kernel space buffering and non-blocking. + */ + + TclSockMinimumBuffers(sock, TCP_BUFFER_SIZE); + + statePtr = NewSocketInfo((SOCKET) sock); + + /* + * Start watching for read/write events on the socket. + */ + + statePtr->selectEvents = FD_READ | FD_CLOSE | FD_WRITE; + SendSelectMessage(tsdPtr, SELECT, statePtr); + + 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; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_OpenTcpServerEx -- + * + * Opens a TCP server socket and creates a channel around it. + * + * Results: + * The channel or NULL if failed. If an error occurred, an error message + * is left in the interp's result if interp is not NULL. + * + * Side effects: + * Opens a server socket and creates a new channel. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_OpenTcpServerEx( + Tcl_Interp *interp, /* For error reporting - may be NULL. */ + const char *service, /* Port number to open. */ + const char *myHost, /* Name of local host. */ + unsigned int flags, /* Flags. */ + Tcl_TcpAcceptProc *acceptProc, + /* Callback for accepting connections from new + * clients. */ + ClientData acceptProcData) /* Data for the callback. */ +{ + SOCKET sock = INVALID_SOCKET; + unsigned short chosenport = 0; + struct addrinfo *addrlist = NULL; + struct addrinfo *addrPtr; /* Socket address to listen on. */ + TcpState *statePtr = NULL; /* The returned value. */ + char channelName[SOCK_CHAN_LENGTH]; + u_long flag = 1; /* Indicates nonblocking mode. */ + const char *errorMsg = NULL; + int optvalue, port; + + if (TclpHasSockets(interp) != TCL_OK) { + return NULL; + } + + /* + * Check that WinSock is initialized; do not call it if not, to prevent + * system crashes. This can happen at exit time if the exit handler for + * WinSock ran before other exit handlers that want to use sockets. + */ + + if (!SocketsEnabled()) { + return NULL; + } + + /* + * Construct the addresses for each end of the socket. + */ + + if (TclSockGetPort(interp, service, "tcp", &port) != TCL_OK) { + errorMsg = "invalid port number"; + goto error; + } + + 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); + } + + /* + * The SO_REUSEADDR option on Windows behaves like SO_REUSEPORT on + * unix systems. + */ + + if (GOT_BITS(flags, TCL_TCPSERVER_REUSEPORT)) { + optvalue = 1; + (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR, + (char *) &optvalue, sizeof(optvalue)); + } + + /* + * Bind to the specified port. + * + * 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. + */ + + statePtr->selectEvents = FD_ACCEPT; + + /* + * 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); + SendSelectMessage(tsdPtr, SELECT, statePtr); + if (Tcl_SetChannelOption(interp, statePtr->channel, "-eofchar", "") + == TCL_ERROR) { + Tcl_Close(NULL, statePtr->channel); + return NULL; + } + return statePtr->channel; + } + + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open socket: %s", + (errorMsg ? errorMsg : Tcl_PosixError(interp)))); + } + + if (sock != INVALID_SOCKET) { + closesocket(sock); + } + return NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TcpAccept -- + * Accept a TCP socket connection. This is called by the event loop. + * + * Results: + * None. + * + * Side effects: + * Creates a new connection socket. Calls the registered callback for the + * connection acceptance mechanism. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +TcpAccept( + TcpFdList *fds, /* Server socket that accepted newSocket. */ + SOCKET newSocket, /* Newly accepted socket. */ + address addr) /* Address of new socket. */ +{ + 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 + * by default. Turn off the inherit bit. + */ + + SetHandleInformation((HANDLE) newSocket, HANDLE_FLAG_INHERIT, 0); + + /* + * Add this socket to the global list of sockets. + */ + + newInfoPtr = NewSocketInfo(newSocket); + + /* + * Select on read/write events and create the channel. + */ + + newInfoPtr->selectEvents = (FD_READ | FD_WRITE | FD_CLOSE); + SendSelectMessage(tsdPtr, SELECT, newInfoPtr); + + sprintf(channelName, SOCK_TEMPLATE, newInfoPtr); + newInfoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, + newInfoPtr, (TCL_READABLE | TCL_WRITABLE)); + if (Tcl_SetChannelOption(NULL, newInfoPtr->channel, "-translation", + "auto crlf") == TCL_ERROR) { + Tcl_Close(NULL, newInfoPtr->channel); + return; + } + if (Tcl_SetChannelOption(NULL, newInfoPtr->channel, "-eofchar", "") + == TCL_ERROR) { + Tcl_Close(NULL, newInfoPtr->channel); + return; + } + + /* + * Invoke the accept callback function. + */ + + if (statePtr->acceptProc != NULL) { + getnameinfo(&(addr.sa), len, host, sizeof(host), port, sizeof(port), + NI_NUMERICHOST|NI_NUMERICSERV); + statePtr->acceptProc(statePtr->acceptProcData, newInfoPtr->channel, + host, atoi(port)); + } +} + +/* + *---------------------------------------------------------------------- + * + * InitSockets -- + * + * Registers the event window for the socket notifier code. + * + * Assumes socketMutex is held. + * + * Results: + * None. + * + * Side effects: + * Register a new window class and creates a + * window for use in asynchronous socket notification. + * + *---------------------------------------------------------------------- + */ + +static void +InitSockets(void) +{ + DWORD id; + ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + + if (!initialized) { + initialized = 1; + TclCreateLateExitHandler(SocketExitHandler, NULL); + + /* + * 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. + */ + + 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; + } + } + + /* + * Check for per-thread initialization. + */ + + if (tsdPtr != NULL) { + return; + } + + /* + * OK, this thread has never done anything with sockets before. Construct + * a worker thread to handle asynchronous events related to sockets + * assigned to _this_ thread. + */ + + 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); + + /* + * Wait for the thread to signal when the window has been created and if + * it is ready to go. + */ + + WaitForSingleObject(tsdPtr->readyEvent, INFINITE); + + if (tsdPtr->hwnd == NULL) { + goto initFailure; /* Trouble creating the window. */ + } + + Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL); + return; + + initFailure: + TclpFinalizeSockets(); + initialized = -1; + return; +} + +/* + *---------------------------------------------------------------------- + * + * SocketsEnabled -- + * + * 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: + * 1 if it is. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +SocketsEnabled(void) +{ + int enabled; + + Tcl_MutexLock(&socketMutex); + enabled = (initialized == 1); + Tcl_MutexUnlock(&socketMutex); + return enabled; +} + + +/* + *---------------------------------------------------------------------- + * + * SocketExitHandler -- + * + * Callback invoked during exit clean up to delete the socket + * communication window. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static void +SocketExitHandler( + ClientData clientData) /* Not used. */ +{ + Tcl_MutexLock(&socketMutex); + + /* + * Make sure the socket event handling window is cleaned-up for, at + * most, this thread. + */ + + TclpFinalizeSockets(); + UnregisterClass(className, TclWinGetTclInstance()); + 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. + * + *---------------------------------------------------------------------- + */ + +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); + + if (!GOT_BITS(flags, TCL_FILE_EVENTS)) { + return; + } + + /* + * 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 (GOT_BITS(statePtr->readyEvents, + statePtr->watchEvents | FD_CONNECT | FD_ACCEPT)) { + Tcl_SetMaxBlockTime(&blockTime); + break; + } + } + SetEvent(tsdPtr->socketListLock); +} + +/* + *---------------------------------------------------------------------- + * + * SocketCheckProc -- + * + * This function is called by Tcl_DoOneEvent to check the socket event + * source for events. + * + * Results: + * None. + * + * Side effects: + * May queue an event. + * + *---------------------------------------------------------------------- + */ + +static void +SocketCheckProc( + ClientData data, /* Not used. */ + int flags) /* Event flags as passed to Tcl_DoOneEvent. */ +{ + TcpState *statePtr; + SocketEvent *evPtr; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if (!GOT_BITS(flags, TCL_FILE_EVENTS)) { + return; + } + + /* + * Queue events for any ready sockets that don't already have events + * queued (caused by persistent states that won't generate WinSock + * events). + */ + + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + for (statePtr = tsdPtr->socketList; statePtr != NULL; + statePtr = statePtr->nextPtr) { + if (GOT_BITS(statePtr->readyEvents, + statePtr->watchEvents | FD_CONNECT | FD_ACCEPT) + && !GOT_BITS(statePtr->flags, SOCKET_PENDING)) { + SET_BITS(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); + } + } + SetEvent(tsdPtr->socketListLock); +} + +/* + *---------------------------------------------------------------------- + * + * SocketEventProc -- + * + * 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: + * 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: + * Whatever the channel callback functions do. + * + *---------------------------------------------------------------------- + */ + +static int +SocketEventProc( + Tcl_Event *evPtr, /* Event to service. */ + int flags) /* Flags that indicate what events to handle, + * such as TCL_FILE_EVENTS. */ +{ + 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 (!GOT_BITS(flags, TCL_FILE_EVENTS)) { + return 0; + } + + /* + * Find the specified socket on the socket list. + */ + + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + for (statePtr = tsdPtr->socketList; statePtr != NULL; + statePtr = statePtr->nextPtr) { + if (statePtr->sockets->fd == eventPtr->socket) { + break; + } + } + + /* + * Discard events that have gone stale. + */ + + if (!statePtr) { + SetEvent(tsdPtr->socketListLock); + return 1; + } + + /* + * Clear flag that (this) event is pending + */ + + CLEAR_BITS(statePtr->flags, SOCKET_PENDING); + + /* + * Continue async connect if pending and ready + */ + + if (GOT_BITS(statePtr->readyEvents, FD_CONNECT)) { + if (GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING)) { + /* + * Do one step and save eventual connect error + */ + + SetEvent(tsdPtr->socketListLock); + WaitForConnect(statePtr,NULL); + } else { + /* + * No async connect reenter pending. Just clear event. + */ + + CLEAR_BITS(statePtr->readyEvents, FD_CONNECT); + SetEvent(tsdPtr->socketListLock); + } + return 1; + } + + /* + * Handle connection requests directly. + */ + + if (GOT_BITS(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; + } + + /* + * 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) { + CLEAR_BITS(statePtr->readyEvents, FD_ACCEPT); + } + + SetEvent(tsdPtr->socketListLock); + + /* + * Caution: TcpAccept() has the side-effect of evaluating the + * server accept script (via AcceptCallbackProc() in tclIOCmd.c), + * which can close the server socket and invalidate 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; + CLEAR_BITS(statePtr->readyEvents, FD_ACCEPT); + + SetEvent(tsdPtr->socketListLock); + return 1; + } + + SetEvent(tsdPtr->socketListLock); + + /* + * Mask off unwanted events and compute the read/write mask so we can + * notify the channel. + */ + + events = statePtr->readyEvents & statePtr->watchEvents; + + if (GOT_BITS(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); + SET_BITS(mask, TCL_READABLE | TCL_WRITABLE); + } else if (GOT_BITS(events, FD_READ)) { + /* + * Throw the readable event if an async connect failed. + */ + + if (GOT_BITS(statePtr->flags, TCP_ASYNC_FAILED)) { + SET_BITS(mask, TCL_READABLE); + } else { + fd_set readFds; + struct timeval timeout; + + /* + * We must check to see if data is really available, since someone + * could have consumed the data in the meantime. Turn off async + * notification so select will work correctly. If the socket is + * still readable, notify the channel driver, otherwise reset the + * async select handler and keep waiting. + */ + + SendSelectMessage(tsdPtr, UNSELECT, 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) { + SET_BITS(mask, TCL_READABLE); + } else { + CLEAR_BITS(statePtr->readyEvents, FD_READ); + SendSelectMessage(tsdPtr, SELECT, statePtr); + } + } + } + + /* + * writable event + */ + + if (GOT_BITS(events, FD_WRITE)) { + SET_BITS(mask, TCL_WRITABLE); + } + + /* + * Call registered event procedures + */ + + if (mask) { + Tcl_NotifyChannel(statePtr->channel, mask); + } + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * AddSocketInfoFd -- + * + * This function adds a SOCKET file descriptor to the 'sockets' linked + * list of a TcpState structure. + * + * Results: + * None. + * + * Side effects: + * None, except for allocation of memory. + * + *---------------------------------------------------------------------- + */ + +static void +AddSocketInfoFd( + TcpState *statePtr, + SOCKET socket) +{ + TcpFdList *fds = statePtr->sockets; + + if (fds == NULL) { + /* + * Add the first FD. + */ + + statePtr->sockets = ckalloc(sizeof(TcpFdList)); + fds = statePtr->sockets; + } else { + /* + * Find end of list and append FD. + */ + + while (fds->next != NULL) { + fds = fds->next; + } + + fds->next = ckalloc(sizeof(TcpFdList)); + fds = fds->next; + } + + /* + * Populate new FD. + */ + + fds->fd = socket; + fds->statePtr = statePtr; + fds->next = NULL; +} + + +/* + *---------------------------------------------------------------------- + * + * NewSocketInfo -- + * + * This function allocates and initializes a new TcpState structure. + * + * Results: + * Returns a newly allocated TcpState. + * + * Side effects: + * None, except for allocation of memory. + * + *---------------------------------------------------------------------- + */ + +static TcpState * +NewSocketInfo(SOCKET socket) +{ + TcpState *statePtr = ckalloc(sizeof(TcpState)); + + memset(statePtr, 0, sizeof(TcpState)); + + /* + * 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. + */ + + AddSocketInfoFd(statePtr, socket); + + return statePtr; +} + +/* + *---------------------------------------------------------------------- + * + * WaitForSocketEvent -- + * + * Waits until one of the specified events occurs on a socket. + * For event FD_CONNECT use WaitForConnect. + * + * Results: + * Returns 1 on success or 0 on failure, with an error code in + * errorCodePtr. + * + * Side effects: + * Processes socket events off the system queue. + * + *---------------------------------------------------------------------- + */ + +static int +WaitForSocketEvent( + TcpState *statePtr, /* Information about this socket. */ + int events, /* Events to look for. May be one of + * FD_READ or FD_WRITE. + */ + int *errorCodePtr) /* Where to store errors? */ +{ + int result = 1; + int oldMode; + ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey); + + /* + * Be sure to disable event servicing so we are truly modal. + */ + + oldMode = Tcl_SetServiceMode(TCL_SERVICE_NONE); + + /* + * Reset WSAAsyncSelect so we have a fresh set of events pending. + */ + + SendSelectMessage(tsdPtr, UNSELECT, statePtr); + SendSelectMessage(tsdPtr, SELECT, statePtr); + + while (1) { + int event_found; + + /* + * Get statePtr lock. + */ + + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + + /* + * Check if event occured. + */ + + event_found = GOT_BITS(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; +} + +/* + *---------------------------------------------------------------------- + * + * SocketThread -- + * + * Helper thread used to manage the socket event handling window. + * + * Results: + * 1 if unable to create socket event window, 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static DWORD WINAPI +SocketThread( + LPVOID arg) +{ + MSG msg; + ThreadSpecificData *tsdPtr = arg; + + /* + * Create a dummy window receiving socket events. + */ + + 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. + */ + + SetEvent(tsdPtr->readyEvent); + + /* + * If unable to create the window, exit this thread immediately. + */ + + if (tsdPtr->hwnd == NULL) { + return 1; + } + + /* + * Process all messages on the socket window until WM_QUIT. This threads + * exits only when instructed to do so by the call to + * PostMessage(SOCKET_TERMINATE) in TclpFinalizeSockets(). + */ + + while (GetMessage(&msg, NULL, 0, 0) > 0) { + DispatchMessage(&msg); + } + + /* + * This releases waiters on thread exit in TclpFinalizeSockets() + */ + + SetEvent(tsdPtr->readyEvent); + + return msg.wParam; +} + + +/* + *---------------------------------------------------------------------- + * + * SocketProc -- + * + * This function is called when WSAAsyncSelect has been used to register + * interest in a socket event, and the event has occurred. + * + * Results: + * 0 on success. + * + * Side effects: + * The flags for the given socket are updated to reflect the event that + * occured. + * + *---------------------------------------------------------------------- + */ + +static LRESULT CALLBACK +SocketProc( + HWND hwnd, + UINT message, + WPARAM wParam, + LPARAM lParam) +{ + int event, error; + SOCKET socket; + TcpState *statePtr; + int info_found = 0; + TcpFdList *fds = NULL; + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) +#ifdef _WIN64 + GetWindowLongPtr(hwnd, GWLP_USERDATA); +#else + GetWindowLong(hwnd, GWL_USERDATA); +#endif + + switch (message) { + default: + return DefWindowProc(hwnd, message, wParam, lParam); + break; + + case WM_CREATE: + /* + * Store the initial tsdPtr, it's from a different thread, so it's not + * directly accessible, but needed. + */ + +#ifdef _WIN64 + SetWindowLongPtr(hwnd, GWLP_USERDATA, + (LONG_PTR) ((LPCREATESTRUCT)lParam)->lpCreateParams); +#else + SetWindowLong(hwnd, GWL_USERDATA, + (LONG) ((LPCREATESTRUCT)lParam)->lpCreateParams); +#endif + break; + + case WM_DESTROY: + PostQuitMessage(0); + break; + + case SOCKET_MESSAGE: + event = WSAGETSELECTEVENT(lParam); + error = WSAGETSELECTERROR(lParam); + socket = (SOCKET) wParam; + + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + + /* + * Find the specified socket on the socket list and update its + * eventState flag. + */ + + for (statePtr = tsdPtr->socketList; statePtr != NULL; + statePtr = statePtr->nextPtr) { + if (FindFDInList(statePtr, socket)) { + info_found = 1; + break; + } + } + + /* + * Check if there is a pending info structure not jet in the list. + */ + + if (!info_found + && tsdPtr->pendingTcpState != NULL + && FindFDInList(tsdPtr->pendingTcpState, socket)) { + statePtr = tsdPtr->pendingTcpState; + info_found = 1; + } + if (info_found) { + /* + * Update the socket state. + * + * A count of FD_ACCEPTS is stored, so if an FD_CLOSE event + * happens, then clear the FD_ACCEPT count. Otherwise, increment + * the count if the current event is an FD_ACCEPT. + */ + + if (GOT_BITS(event, FD_CLOSE)) { + statePtr->acceptEventCount = 0; + CLEAR_BITS(statePtr->readyEvents, FD_WRITE | FD_ACCEPT); + } else if (GOT_BITS(event, FD_ACCEPT)) { + statePtr->acceptEventCount++; + } + + if (GOT_BITS(event, FD_CONNECT)) { + /* + * Remember any error that occurred so we can report + * connection failures. + */ + + if (error != ERROR_SUCCESS) { + statePtr->notifierConnectError = error; + } + } + + /* + * Inform main thread about signaled events + */ + + SET_BITS(statePtr->readyEvents, event); + + /* + * Wake up the Main Thread. + */ + + SetEvent(tsdPtr->readyEvent); + Tcl_ThreadAlert(tsdPtr->threadId); + } + SetEvent(tsdPtr->socketListLock); + break; + + case SOCKET_SELECT: + statePtr = (TcpState *) lParam; + for (fds = statePtr->sockets; fds != NULL; fds = fds->next) { + if (wParam == SELECT) { + WSAAsyncSelect(fds->fd, hwnd, + SOCKET_MESSAGE, statePtr->selectEvents); + } else { + /* + * Clear the selection mask + */ + + WSAAsyncSelect(fds->fd, hwnd, 0, 0); + } + } + break; + + case SOCKET_TERMINATE: + DestroyWindow(hwnd); + break; + } + + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * FindFDInList -- + * + * Return true, if the given file descriptior is contained in the + * file descriptor list. + * + * Results: + * true if found. + * + * Side effects: + * + *---------------------------------------------------------------------- + */ + +static int +FindFDInList( + TcpState *statePtr, + SOCKET socket) +{ + TcpFdList *fds; + for (fds = statePtr->sockets; fds != NULL; fds = fds->next) { + if (fds->fd == socket) { + return 1; + } + } + return 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclWinGetSockOpt, et al. -- + * + * Those functions are historically exported by the stubs table and + * just use the original system calls now. + * + * Warning: + * Those functions are depreciated and will be removed with TCL 9.0. + * + * Results: + * As defined for each function. + * + * Side effects: + * As defined for each function. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_NO_DEPRECATED +#undef TclWinGetSockOpt +int +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, + int optlen) +{ + return setsockopt(s, level, optname, optval, optlen); +} + +#undef TclpInetNtoa +char * +TclpInetNtoa( + struct in_addr addr) +{ + return inet_ntoa(addr); +} +#undef TclWinGetServByName +struct servent * +TclWinGetServByName( + const char *name, + const char *proto) +{ + return getservbyname(name, proto); +} +#endif /* TCL_NO_DEPRECATED */ + +/* + *---------------------------------------------------------------------- + * + * TcpThreadActionProc -- + * + * Insert or remove any thread local refs to this channel. + * + * Results: + * None. + * + * Side effects: + * Changes thread local list of valid channels. + * + *---------------------------------------------------------------------- + */ + +static void +TcpThreadActionProc( + ClientData instanceData, + int action) +{ + ThreadSpecificData *tsdPtr; + TcpState *statePtr = instanceData; + int notifyCmd; + + if (action == TCL_CHANNEL_THREAD_INSERT) { + /* + * Ensure that socket subsystem is initialized in this thread, or else + * sockets will not work. + */ + + Tcl_MutexLock(&socketMutex); + InitSockets(); + Tcl_MutexUnlock(&socketMutex); + + tsdPtr = TCL_TSD_INIT(&dataKey); + + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + statePtr->nextPtr = tsdPtr->socketList; + tsdPtr->socketList = statePtr; + + if (statePtr == tsdPtr->pendingTcpState) { + tsdPtr->pendingTcpState = NULL; + } + + SetEvent(tsdPtr->socketListLock); + + notifyCmd = SELECT; + } else { + TcpState **nextPtrPtr; + int removed = 0; + + tsdPtr = TCL_TSD_INIT(&dataKey); + + /* + * TIP #218, Bugfix: All access to socketList has to be protected by + * the lock. + */ + + WaitForSingleObject(tsdPtr->socketListLock, INFINITE); + for (nextPtrPtr = &(tsdPtr->socketList); (*nextPtrPtr) != NULL; + nextPtrPtr = &((*nextPtrPtr)->nextPtr)) { + if ((*nextPtrPtr) == statePtr) { + (*nextPtrPtr) = statePtr->nextPtr; + removed = 1; + break; + } + } + SetEvent(tsdPtr->socketListLock); + + /* + * This could happen if the channel was created in one thread and then + * moved to another without updating the thread local data in each + * thread. + */ + + if (!removed) { + Tcl_Panic("file info ptr not on thread channel list"); + } + + notifyCmd = UNSELECT; + } + + /* + * Ensure that, or stop, notifications for the socket occur in this + * thread. + */ + + SendSelectMessage(tsdPtr, notifyCmd, statePtr); +} + +/* + * Local Variables: + * 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 new file mode 100644 index 0000000..b3ad626 --- /dev/null +++ b/win/tclWinTest.c @@ -0,0 +1,663 @@ +/* + * tclWinTest.c -- + * + * Contains commands for platform specific tests on Windows. + * + * Copyright (c) 1996 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#ifndef USE_TCL_STUBS +# define USE_TCL_STUBS +#endif +#include "tclInt.h" + +/* + * For TestplatformChmod on Windows + */ +#ifdef _WIN32 +#include <aclapi.h> +#endif + +/* + * MinGW 3.4.2 does not define this. + */ +#ifndef INHERITED_ACE +#define INHERITED_ACE (0x10) +#endif + +/* + * Forward declarations of functions defined later in this file: + */ + +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[]); +static int TestwinclockCmd(ClientData dummy, Tcl_Interp* interp, + int objc, Tcl_Obj *const objv[]); +static int TestwinsleepCmd(ClientData dummy, Tcl_Interp* interp, + int objc, Tcl_Obj *const objv[]); +static Tcl_ObjCmdProc TestExceptionCmd; +static int TestplatformChmod(const char *nativePath, int pmode); +static int TestchmodCmd(ClientData dummy, Tcl_Interp* interp, + int objc, Tcl_Obj *const objv[]); + +/* + *---------------------------------------------------------------------- + * + * TclplatformtestInit -- + * + * Defines commands that test platform specific functionality for Windows + * platforms. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Defines new commands. + * + *---------------------------------------------------------------------- + */ + +int +TclplatformtestInit( + Tcl_Interp *interp) /* Interpreter to add commands to. */ +{ + /* + * Add commands for platform specific tests for Windows here. + */ + + 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); + Tcl_CreateObjCommand(interp, "testwinsleep", TestwinsleepCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testexcept", TestExceptionCmd, NULL, NULL); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TesteventloopCmd -- + * + * This function implements the "testeventloop" command. It is used to + * test the Tcl notifier from an "external" event loop (i.e. not + * Tcl_DoOneEvent()). + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TesteventloopCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + 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 (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option ..."); + return TCL_ERROR; + } + if (strcmp(Tcl_GetString(objv[1]), "done") == 0) { + *framePtr = 1; + } else if (strcmp(Tcl_GetString(objv[1]), "wait") == 0) { + int *oldFramePtr, done; + int oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL); + + /* + * Save the old stack frame pointer and set up the current frame. + */ + + oldFramePtr = framePtr; + framePtr = &done; + + /* + * Enter a standard Windows event loop until the flag changes. Note + * that we do not explicitly call Tcl_ServiceEvent(). + */ + + done = 0; + while (!done) { + MSG msg; + + if (!GetMessage(&msg, NULL, 0, 0)) { + /* + * The application is exiting, so repost the quit message and + * start unwinding. + */ + + PostQuitMessage((int) msg.wParam); + break; + } + TranslateMessage(&msg); + DispatchMessage(&msg); + } + (void) Tcl_SetServiceMode(oldMode); + framePtr = oldFramePtr; + } else { + Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]), + "\": must be done or wait", NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Testvolumetype -- + * + * This function implements the "testvolumetype" command. It is used to + * check the volume type (FAT, NTFS) of a volume. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestvolumetypeCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ +#define VOL_BUF_SIZE 32 + int found; + char volType[VOL_BUF_SIZE]; + const char *path; + + if (objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?name?"); + return TCL_ERROR; + } + if (objc == 2) { + /* + * path has to be really a proper volume, but we don't get query APIs + * for that until NT5 + */ + + path = Tcl_GetString(objv[1]); + } else { + path = NULL; + } + found = GetVolumeInformationA(path, NULL, 0, NULL, NULL, NULL, volType, + VOL_BUF_SIZE); + + if (found == 0) { + Tcl_AppendResult(interp, "could not get volume type for \"", + (path?path:""), "\"", NULL); + TclWinConvertError(GetLastError()); + return TCL_ERROR; + } + Tcl_AppendResult(interp, volType, NULL); + return TCL_OK; +#undef VOL_BUF_SIZE +} + +/* + *---------------------------------------------------------------------- + * + * TestwinclockCmd -- + * + * Command that returns the seconds and microseconds portions of the + * system clock and of the Tcl clock so that they can be compared to + * validate that the Tcl clock is staying in sync. + * + * Usage: + * testclock + * + * Parameters: + * None. + * + * Results: + * Returns a standard Tcl result comprising a four-element list: the + * seconds and microseconds portions of the system clock, and the seconds + * and microseconds portions of the Tcl clock. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TestwinclockCmd( + ClientData dummy, /* Unused */ + Tcl_Interp* interp, /* Tcl interpreter */ + int objc, /* Argument count */ + Tcl_Obj *const objv[]) /* Argument vector */ +{ + static const FILETIME posixEpoch = { 0xD53E8000, 0x019DB1DE }; + /* The Posix epoch, expressed as a Windows + * FILETIME */ + Tcl_Time tclTime; /* Tcl clock */ + FILETIME sysTime; /* System clock */ + Tcl_Obj *result; /* Result of the command */ + LARGE_INTEGER t1, t2; + LARGE_INTEGER p1, p2; + + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, ""); + return TCL_ERROR; + } + + QueryPerformanceCounter(&p1); + + Tcl_GetTime(&tclTime); + GetSystemTimeAsFileTime(&sysTime); + t1.LowPart = posixEpoch.dwLowDateTime; + t1.HighPart = posixEpoch.dwHighDateTime; + t2.LowPart = sysTime.dwLowDateTime; + t2.HighPart = sysTime.dwHighDateTime; + t2.QuadPart -= t1.QuadPart; + + QueryPerformanceCounter(&p2); + + result = Tcl_NewObj(); + Tcl_ListObjAppendElement(interp, result, + Tcl_NewIntObj((int) (t2.QuadPart / 10000000))); + Tcl_ListObjAppendElement(interp, result, + Tcl_NewIntObj((int) ((t2.QuadPart / 10) % 1000000))); + Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(tclTime.sec)); + Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(tclTime.usec)); + + Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(p1.QuadPart)); + Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(p2.QuadPart)); + + Tcl_SetObjResult(interp, result); + + return TCL_OK; +} + +static int +TestwinsleepCmd( + ClientData clientData, /* Unused */ + Tcl_Interp* interp, /* Tcl interpreter */ + int objc, /* Parameter count */ + Tcl_Obj *const * objv) /* Parameter vector */ +{ + int ms; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "ms"); + return TCL_ERROR; + } + if (Tcl_GetIntFromObj(interp, objv[1], &ms) != TCL_OK) { + return TCL_ERROR; + } + Sleep((DWORD) ms); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TestExceptionCmd -- + * + * Causes this process to end with the named exception. Used for testing + * Tcl_WaitPid(). + * + * Usage: + * testexcept <type> + * + * Parameters: + * Type of exception. + * + * Results: + * None, this process closes now and doesn't return. + * + * Side effects: + * This Tcl process closes, hard... Bang! + * + *---------------------------------------------------------------------- + */ + +static int +TestExceptionCmd( + ClientData dummy, /* Unused */ + Tcl_Interp* interp, /* Tcl interpreter */ + int objc, /* Argument count */ + Tcl_Obj *const objv[]) /* Argument vector */ +{ + 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", + "int_divbyzero", "int_overflow", "private_instruction", "inpageerror", + "illegal_instruction", "noncontinue", "stack_overflow", + "invalid_disp", "guard_page", "invalid_handle", "ctrl+c", + NULL + }; + static const DWORD exceptions[] = { + EXCEPTION_ACCESS_VIOLATION, EXCEPTION_DATATYPE_MISALIGNMENT, + EXCEPTION_ARRAY_BOUNDS_EXCEEDED, EXCEPTION_FLT_DENORMAL_OPERAND, + EXCEPTION_FLT_DIVIDE_BY_ZERO, EXCEPTION_FLT_INEXACT_RESULT, + EXCEPTION_FLT_INVALID_OPERATION, EXCEPTION_FLT_OVERFLOW, + EXCEPTION_FLT_STACK_CHECK, EXCEPTION_FLT_UNDERFLOW, + EXCEPTION_INT_DIVIDE_BY_ZERO, EXCEPTION_INT_OVERFLOW, + EXCEPTION_PRIV_INSTRUCTION, EXCEPTION_IN_PAGE_ERROR, + EXCEPTION_ILLEGAL_INSTRUCTION, EXCEPTION_NONCONTINUABLE_EXCEPTION, + EXCEPTION_STACK_OVERFLOW, EXCEPTION_INVALID_DISPOSITION, + EXCEPTION_GUARD_PAGE, EXCEPTION_INVALID_HANDLE, CONTROL_C_EXIT + }; + int cmd; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 0, objv, "<type-of-exception>"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], cmds, "command", 0, + &cmd) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Make sure the GPF dialog doesn't popup. + */ + + SetErrorMode(SEM_FAILCRITICALERRORS | SEM_NOGPFAULTERRORBOX); + + /* + * As Tcl does not handle structured exceptions, this falls all the way + * back up the instruction stack to the C run-time portion that called + * main() where the process will now be terminated with this exception + * code by the default handler the C run-time provides. + */ + + /* SMASH! */ + RaiseException(exceptions[cmd], EXCEPTION_NONCONTINUABLE, 0, NULL); + + /* NOTREACHED */ + return TCL_OK; +} + +static int +TestplatformChmod( + const char *nativePath, + int pmode) +{ + static const SECURITY_INFORMATION infoBits = OWNER_SECURITY_INFORMATION + | GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION; + static const DWORD readOnlyMask = FILE_DELETE_CHILD | FILE_ADD_FILE + | FILE_ADD_SUBDIRECTORY | FILE_WRITE_EA | FILE_APPEND_DATA + | FILE_WRITE_DATA | DELETE; + + /* + * References to security functions (only available on NT and later). + */ + + const BOOL set_readOnly = !(pmode & 0222); + BOOL acl_readOnly_found = FALSE, curAclPresent, curAclDefaulted; + SID_IDENTIFIER_AUTHORITY userSidAuthority = { + SECURITY_WORLD_SID_AUTHORITY + }; + BYTE *secDesc = 0; + DWORD secDescLen, attr, newAclSize; + ACL_SIZE_INFORMATION ACLSize; + PACL curAcl, newAcl = 0; + WORD j; + SID *userSid = 0; + char *userDomain = 0; + int res = 0; + + /* + * Process the chmod request. + */ + + attr = GetFileAttributesA(nativePath); + + /* + * nativePath not found + */ + + if (attr == 0xffffffff) { + res = -1; + goto done; + } + + /* + * If nativePath is not a directory, there is no special handling. + */ + + if (!(attr & FILE_ATTRIBUTE_DIRECTORY)) { + goto done; + } + + /* + * Set the result to error, if the ACL change is successful it will be + * reset to 0. + */ + + res = -1; + + /* + * Read the security descriptor for the directory. Note the first call + * obtains the size of the security descriptor. + */ + + if (!GetFileSecurityA(nativePath, infoBits, NULL, 0, &secDescLen)) { + DWORD secDescLen2 = 0; + + if (GetLastError() != ERROR_INSUFFICIENT_BUFFER) { + goto done; + } + + secDesc = ckalloc(secDescLen); + if (!GetFileSecurityA(nativePath, infoBits, + (PSECURITY_DESCRIPTOR) secDesc, secDescLen, &secDescLen2) + || (secDescLen < secDescLen2)) { + goto done; + } + } + + /* + * Get the World SID. + */ + + 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 (!GetSecurityDescriptorDacl((PSECURITY_DESCRIPTOR) secDesc, + &curAclPresent, &curAcl, &curAclDefaulted)) { + goto done; + } + if (!curAclPresent || !curAcl) { + ACLSize.AclBytesInUse = 0; + ACLSize.AceCount = 0; + } else if (!GetAclInformation(curAcl, &ACLSize, sizeof(ACLSize), + AclSizeInformation)) { + goto done; + } + + /* + * Allocate memory for the new ACL. + */ + + newAclSize = ACLSize.AclBytesInUse + sizeof(ACCESS_DENIED_ACE) + + GetLengthSid(userSid) - sizeof(DWORD); + newAcl = ckalloc(newAclSize); + + /* + * Initialize the new ACL. + */ + + if (!InitializeAcl(newAcl, newAclSize, ACL_REVISION)) { + goto done; + } + + /* + * Add denied to make readonly, this will be known as a "read-only tag". + */ + + if (set_readOnly && !AddAccessDeniedAce(newAcl, ACL_REVISION, + readOnlyMask, userSid)) { + goto done; + } + + acl_readOnly_found = FALSE; + for (j = 0; j < ACLSize.AceCount; j++) { + LPVOID pACE2; + ACE_HEADER *phACE2; + + if (!GetAce(curAcl, j, &pACE2)) { + goto done; + } + + phACE2 = (ACE_HEADER *) pACE2; + + /* + * Do NOT propagate inherited ACEs. + */ + + if (phACE2->AceFlags & INHERITED_ACE) { + continue; + } + + /* + * Skip the "read-only tag" restriction (either added above, or it is + * being removed). + */ + + if (phACE2->AceType == ACCESS_DENIED_ACE_TYPE) { + ACCESS_DENIED_ACE *pACEd = (ACCESS_DENIED_ACE *) phACE2; + + if (pACEd->Mask == readOnlyMask + && EqualSid(userSid, (PSID) &pACEd->SidStart)) { + acl_readOnly_found = TRUE; + continue; + } + } + + /* + * Copy the current ACE from the old to the new ACL. + */ + + if (!AddAce(newAcl, ACL_REVISION, MAXDWORD, (PACL *) pACE2, + ((PACE_HEADER) pACE2)->AceSize)) { + goto done; + } + } + + /* + * Apply the new ACL. + */ + + if (set_readOnly == acl_readOnly_found || SetNamedSecurityInfoA( + (LPSTR) nativePath, SE_FILE_OBJECT, DACL_SECURITY_INFORMATION, + NULL, NULL, newAcl, NULL) == ERROR_SUCCESS) { + res = 0; + } + + done: + if (secDesc) { + ckfree(secDesc); + } + if (newAcl) { + ckfree(newAcl); + } + if (userSid) { + ckfree(userSid); + } + if (userDomain) { + ckfree(userDomain); + } + + if (res != 0) { + return res; + } + + /* + * Run normal chmod command. + */ + + return chmod(nativePath, pmode); +} + +/* + *--------------------------------------------------------------------------- + * + * TestchmodCmd -- + * + * Implements the "testchmod" cmd. Used when testing "file" command. The + * only attribute used by the Windows platform is the user write flag; if + * this is not set, the file is made read-only. Otherwise, the file is + * made read-write. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Changes permissions of specified files. + * + *--------------------------------------------------------------------------- + */ + +static int +TestchmodCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Parameter count */ + Tcl_Obj *const * objv) /* Parameter vector */ +{ + int i, mode; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "mode file ?file ...?"); + return TCL_ERROR; + } + + if (Tcl_GetIntFromObj(interp, objv[1], &mode) != TCL_OK) { + return TCL_ERROR; + } + + for (i = 2; i < objc; i++) { + Tcl_DString buffer; + const char *translated; + + translated = Tcl_TranslateFileName(interp, Tcl_GetString(objv[i]), &buffer); + if (translated == NULL) { + return TCL_ERROR; + } + if (TestplatformChmod(translated, mode) != 0) { + Tcl_AppendResult(interp, translated, ": ", Tcl_PosixError(interp), + NULL); + return TCL_ERROR; + } + Tcl_DStringFree(&buffer); + } + return TCL_OK; +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/win/tclWinThrd.c b/win/tclWinThrd.c new file mode 100644 index 0000000..b9cde72 --- /dev/null +++ b/win/tclWinThrd.c @@ -0,0 +1,1098 @@ +/* + * tclWinThread.c -- + * + * This file implements the Windows-specific thread operations. + * + * 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. + */ + +#include "tclWinInt.h" + +#include <float.h> + +/* Workaround for mingw versions which don't provide this in float.h */ +#ifndef _MCW_EM +# define _MCW_EM 0x0008001F /* Error masks */ +# define _MCW_RC 0x00000300 /* Rounding */ +# define _MCW_PC 0x00030000 /* Precision */ +_CRTIMP unsigned int __cdecl _controlfp (unsigned int unNew, unsigned int unMask); +#endif + +/* + * This is the master lock used to serialize access to other serialization + * data structures. + */ + +static CRITICAL_SECTION masterLock; +static int initialized = 0; + +/* + * This is the master lock used to serialize initialization and finalization + * of Tcl as a whole. + */ + +static CRITICAL_SECTION initLock; + +/* + * allocLock is used by Tcl's version of malloc for synchronization. For + * obvious reasons, cannot use any dyamically allocated storage. + */ + +#ifdef TCL_THREADS + +static struct Tcl_Mutex_ { + CRITICAL_SECTION crit; +} allocLock; +static Tcl_Mutex allocLockPtr = &allocLock; +static int allocOnce = 0; + +#endif /* TCL_THREADS */ + +/* + * The joinLock serializes Create- and ExitThread. This is necessary to + * prevent a race where a new joinable thread exits before the creating thread + * had the time to create the necessary data structures in the emulation + * layer. + */ + +static CRITICAL_SECTION joinLock; + +/* + * Condition variables are implemented with a combination of a per-thread + * Windows Event and a per-condition waiting queue. The idea is that each + * thread has its own Event that it waits on when it is doing a ConditionWait; + * it uses the same event for all condition variables because it only waits on + * one at a time. Each condition variable has a queue of waiting threads, and + * a mutex used to serialize access to this queue. + * + * Special thanks to David Nichols and Jim Davidson for advice on the + * Condition Variable implementation. + */ + +/* + * The per-thread event and queue pointers. + */ + +#ifdef TCL_THREADS + +typedef struct ThreadSpecificData { + HANDLE condEvent; /* Per-thread condition event */ + struct ThreadSpecificData *nextPtr; /* Queue pointers */ + struct ThreadSpecificData *prevPtr; + int flags; /* See flags below */ +} ThreadSpecificData; +static Tcl_ThreadDataKey dataKey; + +#endif /* TCL_THREADS */ + +/* + * State bits for the thread. + * WIN_THREAD_UNINIT Uninitialized. Must be zero because of the way + * ThreadSpecificData is created. + * WIN_THREAD_RUNNING Running, not waiting. + * WIN_THREAD_BLOCKED Waiting, or trying to wait. + */ + +#define WIN_THREAD_UNINIT 0x0 +#define WIN_THREAD_RUNNING 0x1 +#define WIN_THREAD_BLOCKED 0x2 + +/* + * The per condition queue pointers and the Mutex used to serialize access to + * the queue. + */ + +typedef struct { + CRITICAL_SECTION condLock; /* Lock to serialize queuing on the + * condition. */ + struct ThreadSpecificData *firstPtr; /* Queue pointers */ + struct ThreadSpecificData *lastPtr; +} WinCondition; + +/* + * Additions by AOL for specialized thread memory allocator. + */ + +#ifdef USE_THREAD_ALLOC +static DWORD tlsKey; + +typedef struct { + Tcl_Mutex tlock; + CRITICAL_SECTION wlock; +} allocMutex; +#endif /* USE_THREAD_ALLOC */ + +/* + * The per thread data passed from TclpThreadCreate + * to TclWinThreadStart. + */ + +typedef struct { + LPTHREAD_START_ROUTINE lpStartAddress; /* Original startup routine */ + LPVOID lpParameter; /* Original startup data */ + unsigned int fpControl; /* Floating point control word from the + * main thread */ +} WinThread; + + +/* + *---------------------------------------------------------------------- + * + * TclWinThreadStart -- + * + * This procedure is the entry point for all new threads created + * by Tcl on Windows. + * + * Results: + * Various, depending on the result of the wrapped thread start + * routine. + * + * Side effects: + * Arbitrary, since user code is executed. + * + *---------------------------------------------------------------------- + */ + +static DWORD WINAPI +TclWinThreadStart( + LPVOID lpParameter) /* The WinThread structure pointer passed + * from TclpThreadCreate */ +{ + WinThread *winThreadPtr = (WinThread *) lpParameter; + LPTHREAD_START_ROUTINE lpOrigStartAddress; + LPVOID lpOrigParameter; + + if (!winThreadPtr) { + return TCL_ERROR; + } + + _controlfp(winThreadPtr->fpControl, _MCW_EM | _MCW_RC | 0x03000000 /* _MCW_DN */ +#if !defined(_WIN64) + | _MCW_PC +#endif + ); + + lpOrigStartAddress = winThreadPtr->lpStartAddress; + lpOrigParameter = winThreadPtr->lpParameter; + + ckfree(winThreadPtr); + return lpOrigStartAddress(lpOrigParameter); +} + +/* + *---------------------------------------------------------------------- + * + * TclpThreadCreate -- + * + * This procedure creates a new thread. + * + * Results: + * TCL_OK if the thread could be created. The thread ID is returned in a + * parameter. + * + * Side effects: + * A new thread is created. + * + *---------------------------------------------------------------------- + */ + +int +TclpThreadCreate( + Tcl_ThreadId *idPtr, /* Return, the ID 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 + * thread. */ +{ + WinThread *winThreadPtr; /* Per-thread startup info */ + HANDLE tHandle; + + winThreadPtr = (WinThread *)ckalloc(sizeof(WinThread)); + winThreadPtr->lpStartAddress = (LPTHREAD_START_ROUTINE) proc; + winThreadPtr->lpParameter = clientData; + winThreadPtr->fpControl = _controlfp(0, 0); + + EnterCriticalSection(&joinLock); + + *idPtr = 0; /* must initialize as Tcl_Thread is a pointer and + * on WIN64 sizeof void* != sizeof unsigned + */ + +#if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__) + tHandle = (HANDLE) _beginthreadex(NULL, (unsigned) stackSize, + (Tcl_ThreadCreateProc*) TclWinThreadStart, winThreadPtr, + 0, (unsigned *)idPtr); +#else + tHandle = CreateThread(NULL, (DWORD) stackSize, + TclWinThreadStart, winThreadPtr, 0, (LPDWORD)idPtr); +#endif + + if (tHandle == NULL) { + LeaveCriticalSection(&joinLock); + return TCL_ERROR; + } else { + if (flags & TCL_THREAD_JOINABLE) { + TclRememberJoinableThread(*idPtr); + } + + /* + * The only purpose of this is to decrement the reference count so the + * OS resources will be reaquired when the thread closes. + */ + + CloseHandle(tHandle); + LeaveCriticalSection(&joinLock); + return TCL_OK; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_JoinThread -- + * + * This procedure waits upon the exit of the specified thread. + * + * Results: + * TCL_OK if the wait was successful, TCL_ERROR else. + * + * Side effects: + * The result area is set to the exit code of the thread we + * waited upon. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_JoinThread( + Tcl_ThreadId threadId, /* Id of the thread to wait upon */ + int *result) /* Reference to the storage the result of the + * thread we wait upon will be written into. */ +{ + return TclJoinThread(threadId, result); +} + +/* + *---------------------------------------------------------------------- + * + * TclpThreadExit -- + * + * This procedure terminates the current thread. + * + * Results: + * None. + * + * Side effects: + * This procedure terminates the current thread. + * + *---------------------------------------------------------------------- + */ + +void +TclpThreadExit( + int status) +{ + EnterCriticalSection(&joinLock); + TclSignalExitThread(Tcl_GetCurrentThread(), status); + LeaveCriticalSection(&joinLock); + +#if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__) + _endthreadex((unsigned) status); +#else + ExitThread((DWORD) status); +#endif +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetCurrentThread -- + * + * This procedure returns the ID of the currently running thread. + * + * Results: + * A thread ID. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_ThreadId +Tcl_GetCurrentThread(void) +{ + return (Tcl_ThreadId)(size_t)GetCurrentThreadId(); +} + +/* + *---------------------------------------------------------------------- + * + * TclpInitLock + * + * This procedure is used to grab a lock that serializes initialization + * and finalization of Tcl. On some platforms this may also initialize + * the mutex used to serialize creation of more mutexes and thread local + * storage keys. + * + * Results: + * None. + * + * Side effects: + * Acquire the initialization mutex. + * + *---------------------------------------------------------------------- + */ + +void +TclpInitLock(void) +{ + if (!initialized) { + /* + * There is a fundamental race here that is solved by creating the + * first Tcl interpreter in a single threaded environment. Once the + * interpreter has been created, it is safe to create more threads + * that create interpreters in parallel. + */ + + initialized = 1; + InitializeCriticalSection(&joinLock); + InitializeCriticalSection(&initLock); + InitializeCriticalSection(&masterLock); + } + EnterCriticalSection(&initLock); +} + +/* + *---------------------------------------------------------------------- + * + * TclpInitUnlock + * + * This procedure is used to release a lock that serializes + * initialization and finalization of Tcl. + * + * Results: + * None. + * + * Side effects: + * Release the initialization mutex. + * + *---------------------------------------------------------------------- + */ + +void +TclpInitUnlock(void) +{ + LeaveCriticalSection(&initLock); +} + +/* + *---------------------------------------------------------------------- + * + * TclpMasterLock + * + * This procedure is used to grab a lock that serializes creation of + * 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. + * + * Results: + * None. + * + * Side effects: + * Acquire the master mutex. + * + *---------------------------------------------------------------------- + */ + +void +TclpMasterLock(void) +{ + if (!initialized) { + /* + * There is a fundamental race here that is solved by creating the + * first Tcl interpreter in a single threaded environment. Once the + * interpreter has been created, it is safe to create more threads + * that create interpreters in parallel. + */ + + initialized = 1; + InitializeCriticalSection(&joinLock); + InitializeCriticalSection(&initLock); + InitializeCriticalSection(&masterLock); + } + EnterCriticalSection(&masterLock); +} + +/* + *---------------------------------------------------------------------- + * + * TclpMasterUnlock + * + * This procedure is used to release a lock that serializes creation and + * deletion of synchronization objects. + * + * Results: + * None. + * + * Side effects: + * Release the master mutex. + * + *---------------------------------------------------------------------- + */ + +void +TclpMasterUnlock(void) +{ + LeaveCriticalSection(&masterLock); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetAllocMutex + * + * This procedure returns a pointer to a statically initialized mutex for + * use by the memory allocator. The alloctor must use this lock, because + * all other locks are allocated... + * + * Results: + * A pointer to a mutex that is suitable for passing to Tcl_MutexLock and + * Tcl_MutexUnlock. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Mutex * +Tcl_GetAllocMutex(void) +{ +#ifdef TCL_THREADS + if (!allocOnce) { + InitializeCriticalSection(&allocLock.crit); + allocOnce = 1; + } + return &allocLockPtr; +#else + return NULL; +#endif +} + +/* + *---------------------------------------------------------------------- + * + * TclFinalizeLock + * + * This procedure is used to destroy all private resources used in this + * file. + * + * Results: + * None. + * + * Side effects: + * Destroys everything private. TclpInitLock must be held entering this + * function. + * + *---------------------------------------------------------------------- + */ + +void +TclFinalizeLock(void) +{ + TclpMasterLock(); + DeleteCriticalSection(&joinLock); + + /* + * Destroy the critical section that we are holding! + */ + + DeleteCriticalSection(&masterLock); + initialized = 0; + +#ifdef TCL_THREADS + if (allocOnce) { + DeleteCriticalSection(&allocLock.crit); + allocOnce = 0; + } +#endif + + LeaveCriticalSection(&initLock); + + /* + * Destroy the critical section that we were holding. + */ + + DeleteCriticalSection(&initLock); +} + +#ifdef TCL_THREADS + +/* locally used prototype */ +static void FinalizeConditionEvent(ClientData data); + +/* + *---------------------------------------------------------------------- + * + * Tcl_MutexLock -- + * + * This procedure is invoked to lock a mutex. This is a self initializing + * mutex that is automatically finalized during Tcl_Finalize. + * + * Results: + * None. + * + * Side effects: + * May block the current thread. The mutex is aquired when this returns. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_MutexLock( + Tcl_Mutex *mutexPtr) /* The lock */ +{ + CRITICAL_SECTION *csPtr; + + if (*mutexPtr == NULL) { + TclpMasterLock(); + + /* + * Double inside master lock check to avoid a race. + */ + + if (*mutexPtr == NULL) { + csPtr = ckalloc(sizeof(CRITICAL_SECTION)); + InitializeCriticalSection(csPtr); + *mutexPtr = (Tcl_Mutex)csPtr; + TclRememberMutex(mutexPtr); + } + TclpMasterUnlock(); + } + csPtr = *((CRITICAL_SECTION **)mutexPtr); + EnterCriticalSection(csPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_MutexUnlock -- + * + * This procedure is invoked to unlock a mutex. + * + * Results: + * None. + * + * Side effects: + * The mutex is released when this returns. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_MutexUnlock( + Tcl_Mutex *mutexPtr) /* The lock */ +{ + CRITICAL_SECTION *csPtr = *((CRITICAL_SECTION **)mutexPtr); + + LeaveCriticalSection(csPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclpFinalizeMutex -- + * + * This procedure is invoked to clean up one mutex. This is only safe to + * call at the end of time. + * + * Results: + * None. + * + * Side effects: + * The mutex list is deallocated. + * + *---------------------------------------------------------------------- + */ + +void +TclpFinalizeMutex( + Tcl_Mutex *mutexPtr) +{ + CRITICAL_SECTION *csPtr = *(CRITICAL_SECTION **)mutexPtr; + + if (csPtr != NULL) { + DeleteCriticalSection(csPtr); + ckfree(csPtr); + *mutexPtr = NULL; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ConditionWait -- + * + * This procedure is invoked to wait on a condition variable. The mutex + * is atomically released as part of the wait, and automatically grabbed + * when the condition is signaled. + * + * The mutex must be held when this procedure is called. + * + * Results: + * None. + * + * Side effects: + * May block the current thread. The mutex is aquired when this returns. + * Will allocate memory for a HANDLE and initialize this the first time + * this Tcl_Condition is used. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_ConditionWait( + Tcl_Condition *condPtr, /* Really (WinCondition **) */ + Tcl_Mutex *mutexPtr, /* Really (CRITICAL_SECTION **) */ + const Tcl_Time *timePtr) /* Timeout on waiting period */ +{ + WinCondition *winCondPtr; /* Per-condition queue head */ + CRITICAL_SECTION *csPtr; /* Caller's Mutex, after casting */ + DWORD wtime; /* Windows time value */ + int timeout; /* True if we got a timeout */ + int doExit = 0; /* True if we need to do exit setup */ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + /* + * Self initialize the two parts of the condition. The per-condition and + * per-thread parts need to be handled independently. + */ + + if (tsdPtr->flags == WIN_THREAD_UNINIT) { + TclpMasterLock(); + + /* + * Create the per-thread event and queue pointers. + */ + + if (tsdPtr->flags == WIN_THREAD_UNINIT) { + tsdPtr->condEvent = CreateEvent(NULL, TRUE /* manual reset */, + FALSE /* non signaled */, NULL); + tsdPtr->nextPtr = NULL; + tsdPtr->prevPtr = NULL; + tsdPtr->flags = WIN_THREAD_RUNNING; + doExit = 1; + } + TclpMasterUnlock(); + + if (doExit) { + /* + * Create a per-thread exit handler to clean up the condEvent. We + * must be careful to do this outside the Master Lock because + * Tcl_CreateThreadExitHandler uses its own ThreadSpecificData, + * and initializing that may drop back into the Master Lock. + */ + + Tcl_CreateThreadExitHandler(FinalizeConditionEvent, tsdPtr); + } + } + + if (*condPtr == NULL) { + TclpMasterLock(); + + /* + * Initialize the per-condition queue pointers and Mutex. + */ + + if (*condPtr == NULL) { + winCondPtr = ckalloc(sizeof(WinCondition)); + InitializeCriticalSection(&winCondPtr->condLock); + winCondPtr->firstPtr = NULL; + winCondPtr->lastPtr = NULL; + *condPtr = (Tcl_Condition) winCondPtr; + TclRememberCondition(condPtr); + } + TclpMasterUnlock(); + } + csPtr = *((CRITICAL_SECTION **)mutexPtr); + winCondPtr = *((WinCondition **)condPtr); + if (timePtr == NULL) { + wtime = INFINITE; + } else { + wtime = timePtr->sec * 1000 + timePtr->usec / 1000; + } + + /* + * Queue the thread on the condition, using the per-condition lock for + * serialization. + */ + + tsdPtr->flags = WIN_THREAD_BLOCKED; + tsdPtr->nextPtr = NULL; + EnterCriticalSection(&winCondPtr->condLock); + tsdPtr->prevPtr = winCondPtr->lastPtr; /* A: */ + winCondPtr->lastPtr = tsdPtr; + if (tsdPtr->prevPtr != NULL) { + tsdPtr->prevPtr->nextPtr = tsdPtr; + } + if (winCondPtr->firstPtr == NULL) { + winCondPtr->firstPtr = tsdPtr; + } + + /* + * Unlock the caller's mutex and wait for the condition, or a timeout. + * There is a minor issue here in that we don't count down the timeout if + * we get notified, but another thread grabs the condition before we do. + * In that race condition we'll wait again for the full timeout. Timed + * waits are dubious anyway. Either you have the locking protocol wrong + * and are masking a deadlock, or you are using conditions to pause your + * thread. + */ + + LeaveCriticalSection(csPtr); + timeout = 0; + while (!timeout && (tsdPtr->flags & WIN_THREAD_BLOCKED)) { + ResetEvent(tsdPtr->condEvent); + LeaveCriticalSection(&winCondPtr->condLock); + if (WaitForSingleObjectEx(tsdPtr->condEvent, wtime, + TRUE) == WAIT_TIMEOUT) { + timeout = 1; + } + EnterCriticalSection(&winCondPtr->condLock); + } + + /* + * Be careful on timeouts because the signal might arrive right around the + * time limit and someone else could have taken us off the queue. + */ + + if (timeout) { + if (tsdPtr->flags & WIN_THREAD_RUNNING) { + timeout = 0; + } else { + /* + * When dequeuing, we can leave the tsdPtr->nextPtr and + * tsdPtr->prevPtr with dangling pointers because they are + * reinitialilzed w/out reading them when the thread is enqueued + * later. + */ + + if (winCondPtr->firstPtr == tsdPtr) { + winCondPtr->firstPtr = tsdPtr->nextPtr; + } else { + tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr; + } + if (winCondPtr->lastPtr == tsdPtr) { + winCondPtr->lastPtr = tsdPtr->prevPtr; + } else { + tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr; + } + tsdPtr->flags = WIN_THREAD_RUNNING; + } + } + + LeaveCriticalSection(&winCondPtr->condLock); + EnterCriticalSection(csPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ConditionNotify -- + * + * This procedure is invoked to signal a condition variable. + * + * The mutex must be held during this call to avoid races, but this + * interface does not enforce that. + * + * Results: + * None. + * + * Side effects: + * May unblock another thread. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_ConditionNotify( + Tcl_Condition *condPtr) +{ + WinCondition *winCondPtr; + ThreadSpecificData *tsdPtr; + + if (*condPtr != NULL) { + winCondPtr = *((WinCondition **)condPtr); + + if (winCondPtr == NULL) { + return; + } + + /* + * Loop through all the threads waiting on the condition and notify + * them (i.e., broadcast semantics). The queue manipulation is guarded + * by the per-condition coordinating mutex. + */ + + EnterCriticalSection(&winCondPtr->condLock); + while (winCondPtr->firstPtr != NULL) { + tsdPtr = winCondPtr->firstPtr; + winCondPtr->firstPtr = tsdPtr->nextPtr; + if (winCondPtr->lastPtr == tsdPtr) { + winCondPtr->lastPtr = NULL; + } + tsdPtr->flags = WIN_THREAD_RUNNING; + tsdPtr->nextPtr = NULL; + tsdPtr->prevPtr = NULL; /* Not strictly necessary, see A: */ + SetEvent(tsdPtr->condEvent); + } + LeaveCriticalSection(&winCondPtr->condLock); + } else { + /* + * No-one has used the condition variable, so there are no waiters. + */ + } +} + +/* + *---------------------------------------------------------------------- + * + * FinalizeConditionEvent -- + * + * This procedure is invoked to clean up the per-thread event used to + * implement condition waiting. This is only safe to call at the end of + * time. + * + * Results: + * None. + * + * Side effects: + * The per-thread event is closed. + * + *---------------------------------------------------------------------- + */ + +static void +FinalizeConditionEvent( + ClientData data) +{ + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) data; + + tsdPtr->flags = WIN_THREAD_UNINIT; + CloseHandle(tsdPtr->condEvent); +} + +/* + *---------------------------------------------------------------------- + * + * TclpFinalizeCondition -- + * + * This procedure is invoked to clean up a condition variable. This is + * only safe to call at the end of time. + * + * This assumes the Master Lock is held. + * + * Results: + * None. + * + * Side effects: + * The condition variable is deallocated. + * + *---------------------------------------------------------------------- + */ + +void +TclpFinalizeCondition( + Tcl_Condition *condPtr) +{ + WinCondition *winCondPtr = *(WinCondition **)condPtr; + + /* + * Note - this is called long after the thread-local storage is reclaimed. + * The per-thread condition waiting event is reclaimed earlier in a + * per-thread exit handler, which is called before thread local storage is + * reclaimed. + */ + + if (winCondPtr != NULL) { + DeleteCriticalSection(&winCondPtr->condLock); + ckfree(winCondPtr); + *condPtr = NULL; + } +} + + + + +/* + * Additions by AOL for specialized thread memory allocator. + */ +#ifdef USE_THREAD_ALLOC + +Tcl_Mutex * +TclpNewAllocMutex(void) +{ + allocMutex *lockPtr; + + lockPtr = malloc(sizeof(allocMutex)); + if (lockPtr == NULL) { + Tcl_Panic("could not allocate lock"); + } + lockPtr->tlock = (Tcl_Mutex) &lockPtr->wlock; + InitializeCriticalSection(&lockPtr->wlock); + return &lockPtr->tlock; +} + +void +TclpFreeAllocMutex( + Tcl_Mutex *mutex) /* The alloc mutex to free. */ +{ + allocMutex *lockPtr = (allocMutex *) mutex; + + if (!lockPtr) { + return; + } + DeleteCriticalSection(&lockPtr->wlock); + free(lockPtr); +} + +void +TclpInitAllocCache(void) +{ + /* + * We need to make sure that TclpFreeAllocCache is called on each + * thread that calls this, but only on threads that call this. + */ + + tlsKey = TlsAlloc(); + if (tlsKey == TLS_OUT_OF_INDEXES) { + Tcl_Panic("could not allocate thread local storage"); + } +} + +void * +TclpGetAllocCache(void) +{ + void *result; + result = TlsGetValue(tlsKey); + if ((result == NULL) && (GetLastError() != NO_ERROR)) { + Tcl_Panic("TlsGetValue failed from TclpGetAllocCache"); + } + return result; +} + +void +TclpSetAllocCache( + void *ptr) +{ + BOOL success; + success = TlsSetValue(tlsKey, ptr); + if (!success) { + Tcl_Panic("TlsSetValue failed from TclpSetAllocCache"); + } +} + +void +TclpFreeAllocCache( + void *ptr) +{ + BOOL success; + + if (ptr != NULL) { + /* + * 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); + success = TlsSetValue(tlsKey, NULL); + if (!success) { + Tcl_Panic("TlsSetValue failed from TclpFreeAllocCache"); + } + } else { + /* + * Called by us in TclFinalizeThreadAlloc() during the library + * finalization initiated from Tcl_Finalize() + */ + + success = TlsFree(tlsKey); + if (!success) { + Tcl_Panic("TlsFree failed from 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 */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/win/tclWinTime.c b/win/tclWinTime.c new file mode 100644 index 0000000..18702e7 --- /dev/null +++ b/win/tclWinTime.c @@ -0,0 +1,1191 @@ +/* + * tclWinTime.c -- + * + * Contains Windows specific versions of Tcl functions that obtain time + * values from the operating system. + * + * Copyright 1995-1998 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. + */ + +#include "tclInt.h" + +#define SECSPERDAY (60L * 60L * 24L) +#define SECSPERYEAR (SECSPERDAY * 365L) +#define SECSPER4YEAR (SECSPERYEAR * 4L + SECSPERDAY) + +/* + * Number of samples over which to estimate the performance counter. + */ + +#define SAMPLES 64 + +/* + * The following arrays contain the day of year for the last day of each + * month, where index 1 is January. + */ + +#ifndef TCL_NO_DEPRECATED +static const int normalDays[] = { + -1, 30, 58, 89, 119, 150, 180, 211, 242, 272, 303, 333, 364 +}; + +static const int leapDays[] = { + -1, 30, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365 +}; + +typedef struct { + char tzName[64]; /* Time zone name */ + struct tm tm; /* time information */ +} ThreadSpecificData; +static Tcl_ThreadDataKey dataKey; +#endif /* TCL_NO_DEPRECATED */ + +/* + * Data for managing high-resolution timers. + */ + +typedef struct { + CRITICAL_SECTION cs; /* Mutex guarding this structure. */ + int initialized; /* Flag == 1 if this structure is + * initialized. */ + int perfCounterAvailable; /* Flag == 1 if the hardware has a performance + * counter. */ + HANDLE calibrationThread; /* Handle to the thread that keeps the virtual + * clock calibrated. */ + HANDLE readyEvent; /* System event used to trigger the requesting + * thread when the clock calibration procedure + * is initialized for the first time. */ + HANDLE exitEvent; /* Event to signal out of an exit handler to + * tell the calibration loop to terminate. */ + LARGE_INTEGER nominalFreq; /* Nominal frequency of the system performance + * counter, that is, the value returned from + * QueryPerformanceFrequency. */ + + /* + * The following values are used for calculating virtual time. Virtual + * time is always equal to: + * lastFileTime + (current perf counter - lastCounter) + * * 10000000 / curCounterFreq + * and lastFileTime and lastCounter are updated any time that virtual time + * is returned to a caller. + */ + + ULARGE_INTEGER fileTimeLastCall; + LARGE_INTEGER perfCounterLastCall; + LARGE_INTEGER curCounterFreq; + + /* + * Data used in developing the estimate of performance counter frequency + */ + + Tcl_WideUInt fileTimeSample[SAMPLES]; + /* Last 64 samples of system time. */ + Tcl_WideInt perfCounterSample[SAMPLES]; + /* Last 64 samples of performance counter. */ + int sampleNo; /* Current sample number. */ +} TimeInfo; + +static TimeInfo timeInfo = { + { NULL, 0, 0, NULL, NULL, 0 }, + 0, + 0, + (HANDLE) NULL, + (HANDLE) NULL, + (HANDLE) NULL, +#ifdef HAVE_CAST_TO_UNION + (LARGE_INTEGER) (Tcl_WideInt) 0, + (ULARGE_INTEGER) (DWORDLONG) 0, + (LARGE_INTEGER) (Tcl_WideInt) 0, + (LARGE_INTEGER) (Tcl_WideInt) 0, +#else + 0, + 0, + 0, + 0, +#endif + { 0 }, + { 0 }, + 0 +}; + +/* + * Declarations for functions defined later in this file. + */ + +#ifndef TCL_NO_DEPRECATED +static struct tm * ComputeGMT(const time_t *tp); +#endif /* TCL_NO_DEPRECATED */ +static void StopCalibration(ClientData clientData); +static DWORD WINAPI CalibrationThread(LPVOID arg); +static void UpdateTimeEachSecond(void); +static void ResetCounterSamples(Tcl_WideUInt fileTime, + Tcl_WideInt perfCounter, Tcl_WideInt perfFreq); +static Tcl_WideInt AccumulateSample(Tcl_WideInt perfCounter, + Tcl_WideUInt fileTime); +static void NativeScaleTime(Tcl_Time* timebuf, + ClientData clientData); +static void NativeGetTime(Tcl_Time* timebuf, + ClientData clientData); + +/* + * TIP #233 (Virtualized Time): Data for the time hooks, if any. + */ + +Tcl_GetTimeProc *tclGetTimeProcPtr = NativeGetTime; +Tcl_ScaleTimeProc *tclScaleTimeProcPtr = NativeScaleTime; +ClientData tclTimeClientData = NULL; + +/* + *---------------------------------------------------------------------- + * + * TclpGetSeconds -- + * + * This procedure returns the number of seconds from the epoch. On most + * Unix systems the epoch is Midnight Jan 1, 1970 GMT. + * + * Results: + * Number of seconds from the epoch. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +unsigned long +TclpGetSeconds(void) +{ + Tcl_Time t; + + tclGetTimeProcPtr(&t, tclTimeClientData); /* Tcl_GetTime inlined. */ + return t.sec; +} + +/* + *---------------------------------------------------------------------- + * + * TclpGetClicks -- + * + * This procedure returns a value that represents the highest resolution + * clock available on the system. There are no guarantees on what the + * resolution will be. In Tcl we will call this value a "click". The + * start time is also system dependant. + * + * Results: + * Number of clicks from some start time. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +unsigned long +TclpGetClicks(void) +{ + /* + * Use the Tcl_GetTime abstraction to get the time in microseconds, as + * nearly as we can, and return it. + */ + + Tcl_Time now; /* Current Tcl time */ + unsigned long retval; /* Value to return */ + + tclGetTimeProcPtr(&now, tclTimeClientData); /* Tcl_GetTime inlined */ + + retval = (now.sec * 1000000) + now.usec; + return retval; + +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetTime -- + * + * Gets the current system time in seconds and microseconds since the + * beginning of the epoch: 00:00 UCT, January 1, 1970. + * + * Results: + * Returns the current time in timePtr. + * + * Side effects: + * On the first call, initializes a set of static variables to keep track + * of the base value of the performance counter, the corresponding wall + * clock (obtained through ftime) and the frequency of the performance + * counter. Also spins a thread whose function is to wake up periodically + * and monitor these values, adjusting them as necessary to correct for + * drift in the performance counter's oscillator. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_GetTime( + Tcl_Time *timePtr) /* Location to store time information. */ +{ + tclGetTimeProcPtr(timePtr, tclTimeClientData); +} + +/* + *---------------------------------------------------------------------- + * + * NativeScaleTime -- + * + * TIP #233: Scale from virtual time to the real-time. For native scaling + * the relationship is 1:1 and nothing has to be done. + * + * Results: + * Scales the time in timePtr. + * + * Side effects: + * See above. + * + *---------------------------------------------------------------------- + */ + +static void +NativeScaleTime( + Tcl_Time *timePtr, + ClientData clientData) +{ + /* + * Native scale is 1:1. Nothing is done. + */ +} + +/* + *---------------------------------------------------------------------- + * + * NativeGetTime -- + * + * TIP #233: Gets the current system time in seconds and microseconds + * since the beginning of the epoch: 00:00 UCT, January 1, 1970. + * + * Results: + * Returns the current time in timePtr. + * + * Side effects: + * On the first call, initializes a set of static variables to keep track + * of the base value of the performance counter, the corresponding wall + * clock (obtained through ftime) and the frequency of the performance + * counter. Also spins a thread whose function is to wake up periodically + * and monitor these values, adjusting them as necessary to correct for + * drift in the performance counter's oscillator. + * + *---------------------------------------------------------------------- + */ + +static void +NativeGetTime( + Tcl_Time *timePtr, + ClientData clientData) +{ + struct _timeb t; + + /* + * Initialize static storage on the first trip through. + * + * Note: Outer check for 'initialized' is a performance win since it + * avoids an extra mutex lock in the common case. + */ + + if (!timeInfo.initialized) { + TclpInitLock(); + if (!timeInfo.initialized) { + timeInfo.perfCounterAvailable = + QueryPerformanceFrequency(&timeInfo.nominalFreq); + + /* + * Some hardware abstraction layers use the CPU clock in place of + * the real-time clock as a performance counter reference. This + * results in: + * - inconsistent results among the processors on + * multi-processor systems. + * - unpredictable changes in performance counter frequency on + * "gearshift" processors such as Transmeta and SpeedStep. + * + * There seems to be no way to test whether the performance + * counter is reliable, but a useful heuristic is that if its + * frequency is 1.193182 MHz or 3.579545 MHz, it's derived from a + * colorburst crystal and is therefore the RTC rather than the + * TSC. + * + * A sloppier but serviceable heuristic is that the RTC crystal is + * normally less than 15 MHz while the TSC crystal is virtually + * assured to be greater than 100 MHz. Since Win98SE appears to + * fiddle with the definition of the perf counter frequency + * (perhaps in an attempt to calibrate the clock?), we use the + * latter rule rather than an exact match. + * + * We also assume (perhaps questionably) that the vendors have + * gotten their act together on Win64, so bypass all this rubbish + * on that platform. + */ + +#if !defined(_WIN64) + if (timeInfo.perfCounterAvailable + /* + * The following lines would do an exact match on crystal + * frequency: + * && timeInfo.nominalFreq.QuadPart != (Tcl_WideInt)1193182 + * && timeInfo.nominalFreq.QuadPart != (Tcl_WideInt)3579545 + */ + && timeInfo.nominalFreq.QuadPart > (Tcl_WideInt) 15000000){ + /* + * As an exception, if every logical processor on the system + * is on the same chip, we use the performance counter anyway, + * presuming that everyone's TSC is locked to the same + * oscillator. + */ + + SYSTEM_INFO systemInfo; + int regs[4]; + + GetSystemInfo(&systemInfo); + if (TclWinCPUID(0, regs) == TCL_OK + && regs[1] == 0x756e6547 /* "Genu" */ + && regs[3] == 0x49656e69 /* "ineI" */ + && regs[2] == 0x6c65746e /* "ntel" */ + && TclWinCPUID(1, regs) == TCL_OK + && ((regs[0]&0x00000F00) == 0x00000F00 /* Pentium 4 */ + || ((regs[0] & 0x00F00000) /* Extended family */ + && (regs[3] & 0x10000000))) /* Hyperthread */ + && (((regs[1]&0x00FF0000) >> 16)/* CPU count */ + == (int)systemInfo.dwNumberOfProcessors)) { + timeInfo.perfCounterAvailable = TRUE; + } else { + timeInfo.perfCounterAvailable = FALSE; + } + } +#endif /* above code is Win32 only */ + + /* + * If the performance counter is available, start a thread to + * calibrate it. + */ + + if (timeInfo.perfCounterAvailable) { + DWORD id; + + InitializeCriticalSection(&timeInfo.cs); + timeInfo.readyEvent = CreateEvent(NULL, FALSE, FALSE, NULL); + timeInfo.exitEvent = CreateEvent(NULL, FALSE, FALSE, NULL); + timeInfo.calibrationThread = CreateThread(NULL, 256, + CalibrationThread, (LPVOID) NULL, 0, &id); + SetThreadPriority(timeInfo.calibrationThread, + THREAD_PRIORITY_HIGHEST); + + /* + * Wait for the thread just launched to start running, and + * create an exit handler that kills it so that it doesn't + * outlive unloading tclXX.dll + */ + + WaitForSingleObject(timeInfo.readyEvent, INFINITE); + CloseHandle(timeInfo.readyEvent); + Tcl_CreateExitHandler(StopCalibration, NULL); + } + timeInfo.initialized = TRUE; + } + TclpInitUnlock(); + } + + if (timeInfo.perfCounterAvailable && timeInfo.curCounterFreq.QuadPart!=0) { + /* + * Query the performance counter and use it to calculate the current + * time. + */ + + ULARGE_INTEGER fileTimeLastCall; + LARGE_INTEGER perfCounterLastCall, curCounterFreq; + /* Copy with current data of calibration cycle */ + + LARGE_INTEGER curCounter; + /* Current performance counter. */ + Tcl_WideInt curFileTime;/* Current estimated time, expressed as 100-ns + * ticks since the Windows epoch. */ + static LARGE_INTEGER posixEpoch; + /* Posix epoch expressed as 100-ns ticks since + * the windows epoch. */ + Tcl_WideInt usecSincePosixEpoch; + /* Current microseconds since Posix epoch. */ + + posixEpoch.LowPart = 0xD53E8000; + posixEpoch.HighPart = 0x019DB1DE; + + QueryPerformanceCounter(&curCounter); + + /* + * Hold time section locked as short as possible + */ + EnterCriticalSection(&timeInfo.cs); + + fileTimeLastCall.QuadPart = timeInfo.fileTimeLastCall.QuadPart; + perfCounterLastCall.QuadPart = timeInfo.perfCounterLastCall.QuadPart; + curCounterFreq.QuadPart = timeInfo.curCounterFreq.QuadPart; + + LeaveCriticalSection(&timeInfo.cs); + + /* + * If calibration cycle occurred after we get curCounter + */ + if (curCounter.QuadPart <= perfCounterLastCall.QuadPart) { + usecSincePosixEpoch = + (fileTimeLastCall.QuadPart - posixEpoch.QuadPart) / 10; + timePtr->sec = (long) (usecSincePosixEpoch / 1000000); + timePtr->usec = (unsigned long) (usecSincePosixEpoch % 1000000); + return; + } + + /* + * If it appears to be more than 1.1 seconds since the last trip + * through the calibration loop, the performance counter may have + * jumped forward. (See MSDN Knowledge Base article Q274323 for a + * description of the hardware problem that makes this test + * necessary.) If the counter jumps, we don't want to use it directly. + * Instead, we must return system time. Eventually, the calibration + * loop should recover. + */ + + if (curCounter.QuadPart - perfCounterLastCall.QuadPart < + 11 * curCounterFreq.QuadPart / 10 + ) { + curFileTime = fileTimeLastCall.QuadPart + + ((curCounter.QuadPart - perfCounterLastCall.QuadPart) + * 10000000 / curCounterFreq.QuadPart); + + usecSincePosixEpoch = (curFileTime - posixEpoch.QuadPart) / 10; + timePtr->sec = (long) (usecSincePosixEpoch / 1000000); + timePtr->usec = (unsigned long) (usecSincePosixEpoch % 1000000); + return; + } + } + + /* + * High resolution timer is not available. Just use ftime. + */ + + _ftime(&t); + timePtr->sec = (long)t.time; + timePtr->usec = t.millitm * 1000; +} + +/* + *---------------------------------------------------------------------- + * + * StopCalibration -- + * + * Turns off the calibration thread in preparation for exiting the + * process. + * + * Results: + * None. + * + * Side effects: + * Sets the 'exitEvent' event in the 'timeInfo' structure to ask the + * thread in question to exit, and waits for it to do so. + * + *---------------------------------------------------------------------- + */ + +static void +StopCalibration( + ClientData unused) /* Client data is unused */ +{ + SetEvent(timeInfo.exitEvent); + + /* + * If Tcl_Finalize was called from DllMain, the calibration thread is in a + * paused state so we need to timeout and continue. + */ + + WaitForSingleObject(timeInfo.calibrationThread, 100); + CloseHandle(timeInfo.exitEvent); + CloseHandle(timeInfo.calibrationThread); +} + +/* + *---------------------------------------------------------------------- + * + * TclpGetDate -- + * + * This function converts between seconds and struct tm. If useGMT is + * true, then the returned date will be in Greenwich Mean Time (GMT). + * Otherwise, it will be in the local time zone. + * + * Results: + * Returns a static tm structure. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_NO_DEPRECATED +struct tm * +TclpGetDate( + const time_t *t, + int useGMT) +{ + struct tm *tmPtr; + time_t time; + + if (!useGMT) { + tzset(); + + /* + * If we are in the valid range, let the C run-time library handle it. + * Otherwise we need to fake it. Note that this algorithm ignores + * daylight savings time before the epoch. + */ + + /* + * Hm, Borland's localtime manages to return NULL under certain + * circumstances (e.g. wintime.test, test 1.2). Nobody tests for this, + * since 'localtime' isn't supposed to do this, possibly leading to + * crashes. + * + * Patch: We only call this function if we are at least one day into + * the epoch, else we handle it ourselves (like we do for times < 0). + * H. Giese, June 2003 + */ + +#ifdef __BORLANDC__ +#define LOCALTIME_VALIDITY_BOUNDARY SECSPERDAY +#else +#define LOCALTIME_VALIDITY_BOUNDARY 0 +#endif + + if (*t >= LOCALTIME_VALIDITY_BOUNDARY) { + return TclpLocaltime(t); + } + + time = *t - timezone; + + /* + * If we aren't near to overflowing the long, just add the bias and + * use the normal calculation. Otherwise we will need to adjust the + * result at the end. + */ + + if (*t < (LONG_MAX - 2*SECSPERDAY) && *t > (LONG_MIN + 2*SECSPERDAY)) { + tmPtr = ComputeGMT(&time); + } else { + tmPtr = ComputeGMT(t); + + tzset(); + + /* + * Add the bias directly to the tm structure to avoid overflow. + * Propagate seconds overflow into minutes, hours and days. + */ + + time = tmPtr->tm_sec - timezone; + tmPtr->tm_sec = (int)(time % 60); + if (tmPtr->tm_sec < 0) { + tmPtr->tm_sec += 60; + time -= 60; + } + + time = tmPtr->tm_min + time/60; + tmPtr->tm_min = (int)(time % 60); + if (tmPtr->tm_min < 0) { + tmPtr->tm_min += 60; + time -= 60; + } + + time = tmPtr->tm_hour + time/60; + tmPtr->tm_hour = (int)(time % 24); + if (tmPtr->tm_hour < 0) { + tmPtr->tm_hour += 24; + time -= 24; + } + + time /= 24; + tmPtr->tm_mday += (int)time; + tmPtr->tm_yday += (int)time; + tmPtr->tm_wday = (tmPtr->tm_wday + (int)time) % 7; + } + } else { + tmPtr = ComputeGMT(t); + } + return tmPtr; +} + +/* + *---------------------------------------------------------------------- + * + * ComputeGMT -- + * + * This function computes GMT given the number of seconds since the epoch + * (midnight Jan 1 1970). + * + * Results: + * Returns a (per thread) statically allocated struct tm. + * + * Side effects: + * Updates the values of the static struct tm. + * + *---------------------------------------------------------------------- + */ + +static struct tm * +ComputeGMT( + const time_t *tp) +{ + struct tm *tmPtr; + long tmp, rem; + int isLeap; + const int *days; + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + tmPtr = &tsdPtr->tm; + + /* + * Compute the 4 year span containing the specified time. + */ + + tmp = (long)(*tp / SECSPER4YEAR); + rem = (long)(*tp % SECSPER4YEAR); + + /* + * Correct for weird mod semantics so the remainder is always positive. + */ + + if (rem < 0) { + tmp--; + rem += SECSPER4YEAR; + } + + /* + * Compute the year after 1900 by taking the 4 year span and adjusting for + * the remainder. This works because 2000 is a leap year, and 1900/2100 + * are out of the range. + */ + + tmp = (tmp * 4) + 70; + isLeap = 0; + if (rem >= SECSPERYEAR) { /* 1971, etc. */ + tmp++; + rem -= SECSPERYEAR; + if (rem >= SECSPERYEAR) { /* 1972, etc. */ + tmp++; + rem -= SECSPERYEAR; + if (rem >= SECSPERYEAR + SECSPERDAY) { /* 1973, etc. */ + tmp++; + rem -= SECSPERYEAR + SECSPERDAY; + } else { + isLeap = 1; + } + } + } + tmPtr->tm_year = tmp; + + /* + * Compute the day of year and leave the seconds in the current day in the + * remainder. + */ + + tmPtr->tm_yday = rem / SECSPERDAY; + rem %= SECSPERDAY; + + /* + * Compute the time of day. + */ + + tmPtr->tm_hour = rem / 3600; + rem %= 3600; + tmPtr->tm_min = rem / 60; + tmPtr->tm_sec = rem % 60; + + /* + * Compute the month and day of month. + */ + + days = (isLeap) ? leapDays : normalDays; + for (tmp = 1; days[tmp] < tmPtr->tm_yday; tmp++) { + /* empty body */ + } + tmPtr->tm_mon = --tmp; + tmPtr->tm_mday = tmPtr->tm_yday - days[tmp]; + + /* + * Compute day of week. Epoch started on a Thursday. + */ + + tmPtr->tm_wday = (long)(*tp / SECSPERDAY) + 4; + if ((*tp % SECSPERDAY) < 0) { + tmPtr->tm_wday--; + } + tmPtr->tm_wday %= 7; + if (tmPtr->tm_wday < 0) { + tmPtr->tm_wday += 7; + } + + return tmPtr; +} +#endif /* TCL_NO_DEPRECATED */ + +/* + *---------------------------------------------------------------------- + * + * CalibrationThread -- + * + * Thread that manages calibration of the hi-resolution time derived from + * the performance counter, to keep it synchronized with the system + * clock. + * + * Parameters: + * arg - Client data from the CreateThread call. This parameter points to + * the static TimeInfo structure. + * + * Return value: + * None. This thread embeds an infinite loop. + * + * Side effects: + * At an interval of 1s, this thread performs virtual time discipline. + * + * Note: When this thread is entered, TclpInitLock has been called to + * safeguard the static storage. There is therefore no synchronization in the + * body of this procedure. + * + *---------------------------------------------------------------------- + */ + +static DWORD WINAPI +CalibrationThread( + LPVOID arg) +{ + FILETIME curFileTime; + DWORD waitResult; + + /* + * Get initial system time and performance counter. + */ + + GetSystemTimeAsFileTime(&curFileTime); + QueryPerformanceCounter(&timeInfo.perfCounterLastCall); + QueryPerformanceFrequency(&timeInfo.curCounterFreq); + timeInfo.fileTimeLastCall.LowPart = curFileTime.dwLowDateTime; + timeInfo.fileTimeLastCall.HighPart = curFileTime.dwHighDateTime; + + ResetCounterSamples(timeInfo.fileTimeLastCall.QuadPart, + timeInfo.perfCounterLastCall.QuadPart, + timeInfo.curCounterFreq.QuadPart); + + /* + * Wake up the calling thread. When it wakes up, it will release the + * initialization lock. + */ + + SetEvent(timeInfo.readyEvent); + + /* + * Run the calibration once a second. + */ + + while (timeInfo.perfCounterAvailable) { + /* + * If the exitEvent is set, break out of the loop. + */ + + waitResult = WaitForSingleObjectEx(timeInfo.exitEvent, 1000, FALSE); + if (waitResult == WAIT_OBJECT_0) { + break; + } + UpdateTimeEachSecond(); + } + + /* lint */ + return (DWORD) 0; +} + +/* + *---------------------------------------------------------------------- + * + * UpdateTimeEachSecond -- + * + * Callback from the waitable timer in the clock calibration thread that + * updates system time. + * + * Parameters: + * info - Pointer to the static TimeInfo structure + * + * Results: + * None. + * + * Side effects: + * Performs virtual time calibration discipline. + * + *---------------------------------------------------------------------- + */ + +static void +UpdateTimeEachSecond(void) +{ + LARGE_INTEGER curPerfCounter; + /* Current value returned from + * QueryPerformanceCounter. */ + FILETIME curSysTime; /* Current system time. */ + LARGE_INTEGER curFileTime; /* File time at the time this callback was + * scheduled. */ + Tcl_WideInt estFreq; /* Estimated perf counter frequency. */ + Tcl_WideInt vt0; /* Tcl time right now. */ + Tcl_WideInt vt1; /* Tcl time one second from now. */ + Tcl_WideInt tdiff; /* Difference between system clock and Tcl + * time. */ + Tcl_WideInt driftFreq; /* Frequency needed to drift virtual time into + * step over 1 second. */ + + /* + * Sample performance counter and system time. + */ + + QueryPerformanceCounter(&curPerfCounter); + GetSystemTimeAsFileTime(&curSysTime); + curFileTime.LowPart = curSysTime.dwLowDateTime; + curFileTime.HighPart = curSysTime.dwHighDateTime; + + EnterCriticalSection(&timeInfo.cs); + + /* + * We devide by timeInfo.curCounterFreq.QuadPart in several places. That + * value should always be positive on a correctly functioning system. But + * it is good to be defensive about such matters. So if something goes + * wrong and the value does goes to zero, we clear the + * timeInfo.perfCounterAvailable in order to cause the calibration thread + * to shut itself down, then return without additional processing. + */ + + if (timeInfo.curCounterFreq.QuadPart == 0){ + LeaveCriticalSection(&timeInfo.cs); + timeInfo.perfCounterAvailable = 0; + return; + } + + /* + * Several things may have gone wrong here that have to be checked for. + * (1) The performance counter may have jumped. + * (2) The system clock may have been reset. + * + * In either case, we'll need to reinitialize the circular buffer with + * samples relative to the current system time and the NOMINAL performance + * frequency (not the actual, because the actual has probably run slow in + * the first case). Our estimated frequency will be the nominal frequency. + * + * Store the current sample into the circular buffer of samples, and + * estimate the performance counter frequency. + */ + + estFreq = AccumulateSample(curPerfCounter.QuadPart, + (Tcl_WideUInt) curFileTime.QuadPart); + + /* + * We want to adjust things so that time appears to be continuous. + * Virtual file time, right now, is + * + * vt0 = 10000000 * (curPerfCounter - perfCounterLastCall) + * / curCounterFreq + * + fileTimeLastCall + * + * Ideally, we would like to drift the clock into place over a period of 2 + * sec, so that virtual time 2 sec from now will be + * + * vt1 = 20000000 + curFileTime + * + * The frequency that we need to use to drift the counter back into place + * is estFreq * 20000000 / (vt1 - vt0) + */ + + vt0 = 10000000 * (curPerfCounter.QuadPart + - timeInfo.perfCounterLastCall.QuadPart) + / timeInfo.curCounterFreq.QuadPart + + timeInfo.fileTimeLastCall.QuadPart; + vt1 = 20000000 + curFileTime.QuadPart; + + /* + * If we've gotten more than a second away from system time, then drifting + * the clock is going to be pretty hopeless. Just let it jump. Otherwise, + * compute the drift frequency and fill in everything. + */ + + tdiff = vt0 - curFileTime.QuadPart; + if (tdiff > 10000000 || tdiff < -10000000) { + timeInfo.fileTimeLastCall.QuadPart = curFileTime.QuadPart; + timeInfo.curCounterFreq.QuadPart = estFreq; + } else { + driftFreq = estFreq * 20000000 / (vt1 - vt0); + + if (driftFreq > 1003*estFreq/1000) { + driftFreq = 1003*estFreq/1000; + } else if (driftFreq < 997*estFreq/1000) { + driftFreq = 997*estFreq/1000; + } + + timeInfo.fileTimeLastCall.QuadPart = vt0; + timeInfo.curCounterFreq.QuadPart = driftFreq; + } + + timeInfo.perfCounterLastCall.QuadPart = curPerfCounter.QuadPart; + + LeaveCriticalSection(&timeInfo.cs); +} + +/* + *---------------------------------------------------------------------- + * + * ResetCounterSamples -- + * + * Fills the sample arrays in 'timeInfo' with dummy values that will + * yield the current performance counter and frequency. + * + * Results: + * None. + * + * Side effects: + * The array of samples is filled in so that it appears that there are + * SAMPLES samples at one-second intervals, separated by precisely the + * given frequency. + * + *---------------------------------------------------------------------- + */ + +static void +ResetCounterSamples( + Tcl_WideUInt fileTime, /* Current file time */ + Tcl_WideInt perfCounter, /* Current performance counter */ + Tcl_WideInt perfFreq) /* Target performance frequency */ +{ + int i; + for (i=SAMPLES-1 ; i>=0 ; --i) { + timeInfo.perfCounterSample[i] = perfCounter; + timeInfo.fileTimeSample[i] = fileTime; + perfCounter -= perfFreq; + fileTime -= 10000000; + } + timeInfo.sampleNo = 0; +} + +/* + *---------------------------------------------------------------------- + * + * AccumulateSample -- + * + * Updates the circular buffer of performance counter and system time + * samples with a new data point. + * + * Results: + * None. + * + * Side effects: + * The new data point replaces the oldest point in the circular buffer, + * and the descriptive statistics are updated to accumulate the new + * point. + * + * Several things may have gone wrong here that have to be checked for. + * (1) The performance counter may have jumped. + * (2) The system clock may have been reset. + * + * In either case, we'll need to reinitialize the circular buffer with samples + * relative to the current system time and the NOMINAL performance frequency + * (not the actual, because the actual has probably run slow in the first + * case). + */ + +static Tcl_WideInt +AccumulateSample( + Tcl_WideInt perfCounter, + Tcl_WideUInt fileTime) +{ + Tcl_WideUInt workFTSample; /* File time sample being removed from or + * added to the circular buffer. */ + Tcl_WideInt workPCSample; /* Performance counter sample being removed + * from or added to the circular buffer. */ + Tcl_WideUInt lastFTSample; /* Last file time sample recorded */ + Tcl_WideInt lastPCSample; /* Last performance counter sample recorded */ + Tcl_WideInt FTdiff; /* Difference between last FT and current */ + Tcl_WideInt PCdiff; /* Difference between last PC and current */ + Tcl_WideInt estFreq; /* Estimated performance counter frequency */ + + /* + * Test for jumps and reset the samples if we have one. + */ + + if (timeInfo.sampleNo == 0) { + lastPCSample = + timeInfo.perfCounterSample[timeInfo.sampleNo + SAMPLES - 1]; + lastFTSample = + timeInfo.fileTimeSample[timeInfo.sampleNo + SAMPLES - 1]; + } else { + lastPCSample = timeInfo.perfCounterSample[timeInfo.sampleNo - 1]; + lastFTSample = timeInfo.fileTimeSample[timeInfo.sampleNo - 1]; + } + + PCdiff = perfCounter - lastPCSample; + FTdiff = fileTime - lastFTSample; + if (PCdiff < timeInfo.nominalFreq.QuadPart * 9 / 10 + || PCdiff > timeInfo.nominalFreq.QuadPart * 11 / 10 + || FTdiff < 9000000 || FTdiff > 11000000) { + ResetCounterSamples(fileTime, perfCounter, + timeInfo.nominalFreq.QuadPart); + return timeInfo.nominalFreq.QuadPart; + } else { + /* + * Estimate the frequency. + */ + + workPCSample = timeInfo.perfCounterSample[timeInfo.sampleNo]; + workFTSample = timeInfo.fileTimeSample[timeInfo.sampleNo]; + estFreq = 10000000 * (perfCounter - workPCSample) + / (fileTime - workFTSample); + timeInfo.perfCounterSample[timeInfo.sampleNo] = perfCounter; + timeInfo.fileTimeSample[timeInfo.sampleNo] = (Tcl_WideInt) fileTime; + + /* + * Advance the sample number. + */ + + if (++timeInfo.sampleNo >= SAMPLES) { + timeInfo.sampleNo = 0; + } + + return estFreq; + } +} + +/* + *---------------------------------------------------------------------- + * + * TclpGmtime -- + * + * Wrapper around the 'gmtime' library function to make it thread safe. + * + * Results: + * Returns a pointer to a 'struct tm' in thread-specific data. + * + * Side effects: + * Invokes gmtime or gmtime_r as appropriate. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_NO_DEPRECATED +struct tm * +TclpGmtime( + const time_t *timePtr) /* Pointer to the number of seconds since the + * local system's epoch */ +{ + /* + * The MS implementation of gmtime is thread safe because it returns the + * time in a block of thread-local storage, and Windows does not provide a + * Posix gmtime_r function. + */ + + return gmtime(timePtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclpLocaltime -- + * + * Wrapper around the 'localtime' library function to make it thread + * safe. + * + * Results: + * Returns a pointer to a 'struct tm' in thread-specific data. + * + * Side effects: + * Invokes localtime or localtime_r as appropriate. + * + *---------------------------------------------------------------------- + */ + +struct tm * +TclpLocaltime( + 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 + * the time in a block of thread-local storage, and Windows does not + * provide a Posix localtime_r function. + */ + + return localtime(timePtr); +} +#endif /* TCL_NO_DEPRECATED */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetTimeProc -- + * + * TIP #233 (Virtualized Time): Registers two handlers for the + * virtualization of Tcl's access to time information. + * + * Results: + * None. + * + * Side effects: + * Remembers the handlers, alters core behaviour. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetTimeProc( + Tcl_GetTimeProc *getProc, + Tcl_ScaleTimeProc *scaleProc, + ClientData clientData) +{ + tclGetTimeProcPtr = getProc; + tclScaleTimeProcPtr = scaleProc; + tclTimeClientData = clientData; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_QueryTimeProc -- + * + * TIP #233 (Virtualized Time): Query which time handlers are registered. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_QueryTimeProc( + Tcl_GetTimeProc **getProc, + Tcl_ScaleTimeProc **scaleProc, + ClientData *clientData) +{ + if (getProc) { + *getProc = tclGetTimeProcPtr; + } + if (scaleProc) { + *scaleProc = tclScaleTimeProcPtr; + } + if (clientData) { + *clientData = tclTimeClientData; + } +} + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/win/tclooConfig.sh b/win/tclooConfig.sh new file mode 100644 index 0000000..4c2068c --- /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.2.0 diff --git a/win/tclsh.exe.manifest.in b/win/tclsh.exe.manifest.in new file mode 100644 index 0000000..8b06fce --- /dev/null +++ b/win/tclsh.exe.manifest.in @@ -0,0 +1,53 @@ +<?xml version="1.0" encoding="UTF-8" standalone="yes"?> +<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0" + xmlns:asmv3="urn:schemas-microsoft-com:asm.v3"> + <assemblyIdentity + version="@TCL_WIN_VERSION@" + processorArchitecture="@MACHINE@" + name="Tcl.tclsh" + type="win32" + /> + <description>Tcl command line shell (tclsh)</description> + <trustInfo xmlns="urn:schemas-microsoft-com:asm.v3"> + <security> + <requestedPrivileges> + <requestedExecutionLevel + level="asInvoker" + uiAccess="false" + /> + </requestedPrivileges> + </security> + </trustInfo> + <compatibility xmlns="urn:schemas-microsoft-com:compatibility.v1"> + <application> + <!-- Windows 10 --> + <supportedOS Id="{8e0f7a12-bfb3-4fe8-b9a5-48fd50a15a9a}"/> + <!-- Windows 8.1 --> + <supportedOS Id="{1f676c76-80e1-4239-95bb-83d0f6d0da78}"/> + <!-- Windows 8 --> + <supportedOS Id="{4a2f28e3-53b9-4441-ba9c-d69d4a4a6e38}"/> + <!-- Windows 7 --> + <supportedOS Id="{35138b9a-5d96-4fbd-8e2d-a2440225f93a}"/> + <!-- Windows Vista --> + <supportedOS Id="{e2011457-1546-43c5-a5fe-008deee3d3f0}"/> + </application> + </compatibility> + <asmv3:application> + <asmv3:windowsSettings + xmlns="http://schemas.microsoft.com/SMI/2005/WindowsSettings"> + <dpiAware>true</dpiAware> + </asmv3:windowsSettings> + </asmv3:application> + <dependency> + <dependentAssembly> + <assemblyIdentity + type="win32" + name="Microsoft.Windows.Common-Controls" + version="6.0.0.0" + processorArchitecture="@MACHINE@" + publicKeyToken="6595b64144ccf1df" + language="*" + /> + </dependentAssembly> + </dependency> +</assembly> diff --git a/win/tclsh.ico b/win/tclsh.ico Binary files differnew file mode 100644 index 0000000..e254318 --- /dev/null +++ b/win/tclsh.ico diff --git a/win/tclsh.rc b/win/tclsh.rc new file mode 100644 index 0000000..161da50 --- /dev/null +++ b/win/tclsh.rc @@ -0,0 +1,82 @@ +// +// Version Resource Script +// + +#include <winver.h> +#include <tcl.h> + +// +// build-up the name suffix that defines the type of build this is. +// +#if TCL_THREADS +#define SUFFIX_THREADS "t" +#else +#define SUFFIX_THREADS "" +#endif + +#if STATIC_BUILD +#define SUFFIX_STATIC "s" +#else +#define SUFFIX_STATIC "" +#endif + +#if DEBUG && !UNCHECKED +#define SUFFIX_DEBUG "g" +#else +#define SUFFIX_DEBUG "" +#endif + +#define SUFFIX SUFFIX_THREADS SUFFIX_STATIC SUFFIX_DEBUG + + +LANGUAGE 0x9, 0x1 /* LANG_ENGLISH, SUBLANG_DEFAULT */ + +VS_VERSION_INFO VERSIONINFO + FILEVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL + PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL + FILEFLAGSMASK 0x3fL +#ifdef DEBUG + FILEFLAGS VS_FF_DEBUG +#else + FILEFLAGS 0x0L +#endif + FILEOS VOS__WINDOWS32 + FILETYPE VFT_APP + FILESUBTYPE 0x0L +BEGIN + BLOCK "StringFileInfo" + BEGIN + BLOCK "040904b0" + BEGIN + VALUE "FileDescription", "Tclsh Application\0" + VALUE "OriginalFilename", "tclsh" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) SUFFIX ".exe\0" + VALUE "CompanyName", "ActiveState Corporation\0" + VALUE "FileVersion", TCL_PATCH_LEVEL + VALUE "LegalCopyright", "Copyright \251 2000 by ActiveState Corporation, et al\0" + VALUE "ProductName", "Tcl " TCL_VERSION " for Windows\0" + VALUE "ProductVersion", TCL_PATCH_LEVEL + END + END + BLOCK "VarFileInfo" + BEGIN + VALUE "Translation", 0x409, 1200 + END +END + +// +// Icon +// + +tclsh ICON DISCARDABLE "tclsh.ico" + +// +// This is needed for Windows 8.1 onwards. +// + +#ifndef RT_MANIFEST +#define RT_MANIFEST 24 +#endif +#ifndef CREATEPROCESS_MANIFEST_RESOURCE_ID +#define CREATEPROCESS_MANIFEST_RESOURCE_ID 1 +#endif +CREATEPROCESS_MANIFEST_RESOURCE_ID RT_MANIFEST "tclsh.exe.manifest" |