summaryrefslogtreecommitdiffstats
path: root/win
diff options
context:
space:
mode:
Diffstat (limited to 'win')
-rw-r--r--win/Makefile.in883
-rw-r--r--win/README99
-rw-r--r--win/aclocal.m41
-rw-r--r--win/buildall.vc.bat103
-rw-r--r--win/cat.c41
-rw-r--r--win/coffbase.txt43
-rwxr-xr-xwin/configure6463
-rw-r--r--win/configure.ac464
-rw-r--r--win/makefile.bc594
-rw-r--r--win/makefile.vc1242
-rw-r--r--win/nmakehlp.c697
-rw-r--r--win/rules.vc703
-rw-r--r--win/tcl.dsp1567
-rw-r--r--win/tcl.dsw29
-rw-r--r--win/tcl.hpj.in19
-rw-r--r--win/tcl.m41299
-rw-r--r--win/tcl.rc57
-rw-r--r--win/tclAppInit.c338
-rw-r--r--win/tclConfig.sh.in180
-rw-r--r--win/tclWin32Dll.c801
-rw-r--r--win/tclWinChan.c1588
-rw-r--r--win/tclWinConsole.c1502
-rw-r--r--win/tclWinDde.c1888
-rw-r--r--win/tclWinError.c428
-rw-r--r--win/tclWinFCmd.c1968
-rwxr-xr-xwin/tclWinFile.c3204
-rw-r--r--win/tclWinInit.c722
-rw-r--r--win/tclWinInt.h89
-rw-r--r--win/tclWinLoad.c402
-rw-r--r--win/tclWinNotify.c618
-rw-r--r--win/tclWinPipe.c3167
-rw-r--r--win/tclWinPort.h571
-rw-r--r--win/tclWinReg.c1547
-rw-r--r--win/tclWinSerial.c2297
-rw-r--r--win/tclWinSock.c3367
-rw-r--r--win/tclWinTest.c663
-rw-r--r--win/tclWinThrd.c1098
-rw-r--r--win/tclWinTime.c1165
-rw-r--r--win/tclooConfig.sh19
-rw-r--r--win/tclsh.exe.manifest.in53
-rw-r--r--win/tclsh.icobin0 -> 57022 bytes
-rw-r--r--win/tclsh.rc82
42 files changed, 42061 insertions, 0 deletions
diff --git a/win/Makefile.in b/win/Makefile.in
new file mode 100644
index 0000000..83f9b67
--- /dev/null
+++ b/win/Makefile.in
@@ -0,0 +1,883 @@
+#
+# 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}" -DTCL_TOMMATH \
+-DMP_PREC=4 -I"${TOMMATH_DIR_NATIVE}" -I"${WIN_DIR_NATIVE}" \
+${AC_FLAGS} ${COMPILE_DEBUG_FLAGS} ${NO_DEPRECATED_FLAGS}
+
+CC_OBJNAME = @CC_OBJNAME@
+CC_EXENAME = @CC_EXENAME@
+
+STUB_CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \
+-I"${GENERIC_DIR_NATIVE}" -DTCL_TOMMATH -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_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_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.10 as a Tcl Module";
+ @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.8.10.tm;
+ @echo "Installing library opt0.4 directory";
+ @for j in $(ROOT_DIR)/library/opt/*.tcl; \
+ do \
+ $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \
+ done;
+ @echo "Installing package msgcat 1.6.0 as a Tcl Module";
+ @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.6.0.tm;
+ @echo "Installing package 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..73d6d9f
--- /dev/null
+++ b/win/configure
@@ -0,0 +1,6463 @@
+#! /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_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="a0"
+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 -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..7405bf4
--- /dev/null
+++ b/win/configure.ac
@@ -0,0 +1,464 @@
+#! /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="a0"
+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_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.bc b/win/makefile.bc
new file mode 100644
index 0000000..bee61d7
--- /dev/null
+++ b/win/makefile.bc
@@ -0,0 +1,594 @@
+#
+# Makefile for Borland C++ 5.5 (or C++ Builder 5), adapted from the makefile
+# for Visual C++ that came with tcl 8.3.3
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# Copyright (c) 1995-1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+
+# TIP #59 information.
+#
+# This makefile does not set the following configuration cpp
+# defines. Behind the defines are the makefile variables listed to set
+# to -D... when that feature is enabled.
+#
+# - TCL_CFG_PROFILED PROFDEFINES
+# - TCL_CFG_OPTIMIZED OPTDEFINES
+# - TCL_CFG_DO64BIT SIXFOURDEFINES
+
+# Have a look at the complete description on how to build and test Tcl with
+# the current Borland compilers at www.ratiosoft.com/tcl/borland.
+#
+# Usage:
+# - Adapt the paths below to match your compiler's location
+# - Make sure the compiler's bin directory is on your path
+# - Open a console
+# - To make a debug version enter
+# make -fmakefile.bc -DNODEBUG=0 xxx
+# where 'xxx' is the target you want (e.g. 'all', 'test', ...)
+# Please note: I omitted the 'd' suffix for debug versions because Tcl
+# will always call tclpip83.dll and not tclpip83d.dll, causing an error.
+# ^
+# Besides, the debug version goes into a separate directory, so there
+# should be no problem having DLLs and EXEs with the same name.
+# If you prefer your debug version having the 'd' suffix just uncomment
+# the line
+# #DBGX = d
+#
+# - To make a 'normal' version enter
+# make -fmakefile.bc xxx
+# where 'xxx' is the target you want (e.g. 'all', 'test', ...)
+#
+# DISCLAIMER:
+# This makefile has an experimental status - that is those targets which
+# have been modified do in fact compile and link with Borland's C++
+# Builder 5 and with the free Borland compiler (Borland C++ 5.5).
+# However the author assumes no responsiblity for any effect which the use of
+# this makefile or of the resulting programs might have on your system.
+#
+# Not yet modified:
+# - The 'plug-in-DLL' and the associated shell.
+#
+# Suggestions and / or improvements are always welcome.
+#
+# May 2001, H. Giese (hgiese@ratiosoft.com)
+#
+
+# Does not depend on the presence of any environment variables in
+# order to compile tcl; all needed information is derived from
+# location of the compiler directories.
+
+#
+# Project directories
+#
+# ROOT = top of source tree
+#
+# TOOLS32 = location of Borland development tools.
+#
+# INSTALLDIR = where the install-targets should copy the binaries and
+# support files
+#
+
+ROOT = ..
+INSTALLDIR = c:\program files\tcl
+
+# If you have C++ Builder 5 or the free Borland C++ 5.5 compiler
+# adapt the following paths as appropriate for your system
+TOOLS32 = c:\dev\bcc55
+TOOLS32_rc = c:\dev\bcc55
+#TOOLS32 = c:\bc55
+#TOOLS32_rc = c:\bc55
+
+cc32 = "$(TOOLS32)\bin\bcc32.exe"
+link32 = "$(TOOLS32)\bin\ilink32.exe"
+lib32 = "$(TOOLS32)\bin\tlib.exe"
+rc32 = "$(TOOLS32_rc)\bin\brcc32.exe"
+include32 = -I"$(TOOLS32)\include"
+libpath32 = -L"$(TOOLS32)\lib"
+
+# Uncomment the following line to compile with thread support
+#THREADDEFINES = -DTCL_THREADS=1
+
+# Allow definition of NDEBUG via command line
+# Set NODEBUG to 0 to compile with symbols
+!if !defined(NODEBUG)
+NODEBUG = 1
+!endif
+
+# CFG_ENCODING=encoding
+# name of encoding for configuration information. Defaults
+# to cp1252
+!if !defined(CFG_ENCODING)
+CFG_ENCODING = \"cp1252\"
+!endif
+
+# The following defines can be used to control the amount of debugging
+# code that is added to the compilation.
+#
+# -DTCL_MEM_DEBUG Enables the debugging memory allocator.
+# -DTCL_COMPILE_DEBUG Enables byte compilation logging.
+# -DTCL_COMPILE_STATS Enables byte compilation statistics gathering.
+# -DUSE_TCLALLOC=0 Disables the Tcl memory allocator in favor
+# of the native malloc implementation. This is
+# needed when using Purify.
+#
+#DEBUGDEFINES = -DTCL_MEM_DEBUG -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS
+#DEBUGDEFINES = -DUSE_TCLALLOC=0
+
+######################################################################
+# Do not modify below this line
+######################################################################
+
+NAMEPREFIX = tcl
+STUBPREFIX = $(NAMEPREFIX)stub
+DOTVERSION = 8.7
+VERSION = 87
+
+DDEVERSION = 14
+DDEDOTVERSION = 1.4
+
+REGVERSION = 13
+REGDOTVERSION = 1.3
+
+BINROOT = ..
+!IF "$(NODEBUG)" == "1"
+TMPDIRNAME = Release
+DBGX =
+SYMDEFINES = -DNDEBUG
+!ELSE
+TMPDIRNAME = Debug
+#DBGX = d
+DBGX =
+SYMDEFINES = -DTCL_CFG_DEBUG
+!ENDIF
+TMPDIR = $(BINROOT)\$(TMPDIRNAME)
+OUTDIRNAME = $(TMPDIRNAME)
+OUTDIR = $(TMPDIR)
+
+TCLLIB = $(OUTDIR)\$(NAMEPREFIX)$(VERSION)$(DBGX).lib
+TCLDLLNAME = $(NAMEPREFIX)$(VERSION)$(DBGX).dll
+TCLDLL = $(OUTDIR)\$(TCLDLLNAME)
+
+TCLSTUBLIBNAME = $(STUBPREFIX)$(VERSION)$(DBGX).lib
+TCLSTUBLIB = $(OUTDIR)\$(TCLSTUBLIBNAME)
+
+TCLPLUGINLIB = $(OUTDIR)\$(NAMEPREFIX)$(VERSION)p$(DBGX).lib
+TCLPLUGINDLLNAME = $(NAMEPREFIX)$(VERSION)p$(DBGX).dll
+TCLPLUGINDLL = $(OUTDIR)\$(TCLPLUGINDLLNAME)
+TCLSH = $(OUTDIR)\$(NAMEPREFIX)sh$(VERSION)$(DBGX).exe
+TCLSHP = $(OUTDIR)\$(NAMEPREFIX)shp$(VERSION)$(DBGX).exe
+TCLREGDLLNAME = $(NAMEPREFIX)reg$(REGVERSION)$(DBGX).dll
+TCLREGDLL = $(OUTDIR)\$(TCLREGDLLNAME)
+TCLDDEDLLNAME = $(NAMEPREFIX)dde$(DDEVERSION)$(DBGX).dll
+TCLDDEDLL = $(OUTDIR)\$(TCLDDEDLLNAME)
+TCLTEST = $(OUTDIR)\$(NAMEPREFIX)test.exe
+CAT32 = $(TMPDIR)\cat32.exe
+RMDIR = .\rmd.bat
+MKDIR = .\mkd.bat
+RM = del
+
+LIB_INSTALL_DIR = $(INSTALLDIR)\lib
+BIN_INSTALL_DIR = $(INSTALLDIR)\bin
+SCRIPT_INSTALL_DIR = $(INSTALLDIR)\lib\tcl$(DOTVERSION)
+INCLUDE_INSTALL_DIR = $(INSTALLDIR)\include
+
+TCLSHOBJS = \
+ $(TMPDIR)\tclAppInit.obj
+
+TCLTESTOBJS = \
+ $(TMPDIR)\tclTest.obj \
+ $(TMPDIR)\tclTestObj.obj \
+ $(TMPDIR)\tclTestProcBodyObj.obj \
+ $(TMPDIR)\tclThreadTest.obj \
+ $(TMPDIR)\tclWinTest.obj \
+ $(TMPDIR)\testMain.obj
+
+TCLOBJS = \
+ $(TMPDIR)\regcomp.obj \
+ $(TMPDIR)\regexec.obj \
+ $(TMPDIR)\regfree.obj \
+ $(TMPDIR)\regerror.obj \
+ $(TMPDIR)\tclAlloc.obj \
+ $(TMPDIR)\tclAsync.obj \
+ $(TMPDIR)\tclBasic.obj \
+ $(TMPDIR)\tclBinary.obj \
+ $(TMPDIR)\tclCkalloc.obj \
+ $(TMPDIR)\tclClock.obj \
+ $(TMPDIR)\tclCmdAH.obj \
+ $(TMPDIR)\tclCmdIL.obj \
+ $(TMPDIR)\tclCmdMZ.obj \
+ $(TMPDIR)\tclCompCmds.obj \
+ $(TMPDIR)\tclCompCmdsGR.obj \
+ $(TMPDIR)\tclCompCmdsSZ.obj \
+ $(TMPDIR)\tclCompExpr.obj \
+ $(TMPDIR)\tclCompile.obj \
+ $(TMPDIR)\tclConfig.obj \
+ $(TMPDIR)\tclDate.obj \
+ $(TMPDIR)\tclDictObj.obj \
+ $(TMPDIR)\tclDisassemble.obj \
+ $(TMPDIR)\tclEncoding.obj \
+ $(TMPDIR)\tclEnsemble.obj \
+ $(TMPDIR)\tclEnv.obj \
+ $(TMPDIR)\tclEvent.obj \
+ $(TMPDIR)\tclExecute.obj \
+ $(TMPDIR)\tclFCmd.obj \
+ $(TMPDIR)\tclFileName.obj \
+ $(TMPDIR)\tclGet.obj \
+ $(TMPDIR)\tclHash.obj \
+ $(TMPDIR)\tclHistory.obj \
+ $(TMPDIR)\tclIndexObj.obj \
+ $(TMPDIR)\tclInterp.obj \
+ $(TMPDIR)\tclIO.obj \
+ $(TMPDIR)\tclIOCmd.obj \
+ $(TMPDIR)\tclIOGT.obj \
+ $(TMPDIR)\tclIOSock.obj \
+ $(TMPDIR)\tclIOUtil.obj \
+ $(TMPDIR)\tclLink.obj \
+ $(TMPDIR)\tclLiteral.obj \
+ $(TMPDIR)\tclListObj.obj \
+ $(TMPDIR)\tclLoad.obj \
+ $(TMPDIR)\tclMain.obj \
+ $(TMPDIR)\tclNamesp.obj \
+ $(TMPDIR)\tclNotify.obj \
+ $(TMPDIR)\tclOO.obj \
+ $(TMPDIR)\tclOOBasic.obj \
+ $(TMPDIR)\tclOOCall.obj \
+ $(TMPDIR)\tclOODefineCmds.obj \
+ $(TMPDIR)\tclOOInfo.obj \
+ $(TMPDIR)\tclOOMethod.obj \
+ $(TMPDIR)\tclOOStubInit.obj \
+ $(TMPDIR)\tclObj.obj \
+ $(TMPDIR)\tclOptimize.obj \
+ $(TMPDIR)\tclPanic.obj \
+ $(TMPDIR)\tclParse.obj \
+ $(TMPDIR)\tclPipe.obj \
+ $(TMPDIR)\tclPkg.obj \
+ $(TMPDIR)\tclPkgConfig.obj \
+ $(TMPDIR)\tclPosixStr.obj \
+ $(TMPDIR)\tclPreserve.obj \
+ $(TMPDIR)\tclProc.obj \
+ $(TMPDIR)\tclRegexp.obj \
+ $(TMPDIR)\tclResolve.obj \
+ $(TMPDIR)\tclResult.obj \
+ $(TMPDIR)\tclScan.obj \
+ $(TMPDIR)\tclStringObj.obj \
+ $(TMPDIR)\tclStubInit.obj \
+ $(TMPDIR)\tclThread.obj \
+ $(TMPDIR)\tclThreadJoin.obj \
+ $(TMPDIR)\tclTimer.obj \
+ $(TMPDIR)\tclTrace.obj \
+ $(TMPDIR)\tclUtf.obj \
+ $(TMPDIR)\tclUtil.obj \
+ $(TMPDIR)\tclVar.obj \
+ $(TMPDIR)\tclWin32Dll.obj \
+ $(TMPDIR)\tclWinChan.obj \
+ $(TMPDIR)\tclWinConsole.obj \
+ $(TMPDIR)\tclWinSerial.obj \
+ $(TMPDIR)\tclWinError.obj \
+ $(TMPDIR)\tclWinFCmd.obj \
+ $(TMPDIR)\tclWinFile.obj \
+ $(TMPDIR)\tclWinInit.obj \
+ $(TMPDIR)\tclWinLoad.obj \
+ $(TMPDIR)\tclWinNotify.obj \
+ $(TMPDIR)\tclWinPipe.obj \
+ $(TMPDIR)\tclWinSock.obj \
+ $(TMPDIR)\tclWinThrd.obj \
+ $(TMPDIR)\tclWinTime.obj \
+ $(TMPDIR)\tclZlib.obj
+
+TCLSTUBOBJS = \
+ $(TMPDIR)\tclStubLib.obj \
+ $(TMPDIR)\tclTomMathStubLib.obj \
+ $(TMPDIR)\tclOOStubLib.obj
+
+WINDIR = $(ROOT)\win
+GENERICDIR = $(ROOT)\generic
+
+TCL_INCLUDES = -I"$(WINDIR)" -I"$(GENERICDIR)"
+TCL_DEFINES = $(DEBUGDEFINES) $(THREADDEFINES) $(SYMDEFINES) \
+ $(PROFDEFINES) $(OPTDEFINES) $(SIXFOURDEFINES) \
+ -DTCL_CFGVAL_ENCODING=${CFG_ENCODING}
+### TODO: Add -DHAVE_ZLIB=1
+
+######################################################################
+# Compiler flags
+######################################################################
+
+!IF "$(NODEBUG)" == "1"
+# these macros cause maximum optimization and no symbols
+cdebug = -v- -vi- -O2 -D_DEBUG
+!ELSE
+# these macros enable debugging
+cdebug = -k -Od -r- -v -vi- -y
+!ENDIF
+
+SYSDEFINES = _MT;NO_STRICT;_NO_VCL
+
+# declarations common to all compiler options
+cbase = -c -q -3 -a4 -g0 -tWM -Ve -Vx -X-
+WARNINGS = -w-rch -w-pch -w-par -w-dup -w-pro -w-dpu
+
+ccons = -tWC
+
+INCLUDEPATH = $(include32) $(TCL_INCLUDES)
+
+CFLAGS = $(cdebug) $(cbase) $(INCLUDEPATH) $(WARNINGS) -D$(SYSDEFINES)
+TCL_CFLAGS = $(CFLAGS) $(TCL_DEFINES)
+CONS_CFLAGS = $(CFLAGS) $(TCL_DEFINES) $(ccons)
+
+######################################################################
+# Linker flags
+######################################################################
+
+!IF "$(NODEBUG)" == "1"
+ldebug =
+!ELSE
+ldebug = -v
+!ENDIF
+
+# declarations common to all linker options
+LNFLAGS = -D"" -Gn -I$(TMPDIR) -x $(ldebug) $(libpath32)
+# -Gi: create lib file (is -Gl in doc)
+# -aa: Windows app, -ap: Windows console app
+LNFLAGS_DLL = -ap -Gi -Tpd
+LNFLAGS_CONS = -ap -Tpe
+
+LNLIBS = import32 cw32mt
+
+
+######################################################################
+# Project specific targets
+######################################################################
+
+release: setup $(TCLSH) dlls
+dlls: setup $(TCLREGDLL) $(TCLDDEDLL)
+all: setup $(TCLSH) dlls $(CAT32)
+tcltest: setup $(TCLTEST) dlls $(CAT32)
+plugin: setup $(TCLPLUGINDLL) $(TCLSHP)
+install: install-binaries install-libraries
+
+test: setup $(TCLTEST) dlls $(CAT32)
+ set TCL_LIBRARY=$(ROOT)/library
+ $(TCLTEST) $(ROOT)/tests/all.tcl
+
+setup:
+ @if not exist $(OUT_DIR)\nul mkdir $(OUT_DIR) &\
+ echo *** Created directory '$(OUT_DIR)'
+ @if not exist $(TMP_DIR)\nul mkdir $(TMP_DIR) &\
+ echo *** Created directory '$(TMP_DIR)'
+
+
+$(TCLLIB): $(TCLDLL)
+
+$(TCLDLL): $(TCLOBJS) $(TMPDIR)\$(NAMEPREFIX).res
+ $(link32) $(ldebug) $(LNFLAGS) $(LNFLAGS_DLL) $(TOOLS32)\lib\c0d32 @&&!
+ $(TCLOBJS), $@, -x, $(LNLIBS),, $(TMPDIR)\$(NAMEPREFIX).res
+!
+
+$(TCLSTUBLIB): $(TCLSTUBOBJS)
+ $(lib32) /u $@ $(TCLSTUBOBJS)
+
+$(TCLPLUGINLIB): $(TCLPLUGINDLL)
+
+$(TCLPLUGINDLL): $(TCLOBJS) $(TMPDIR)\tcl.res
+ $(link32) $(ldebug) $(dlllflags) \
+ -out:$@ $(TMPDIR)\tcl.res $(guilibsdll) @&&!
+$(TCLOBJS)
+!
+
+$(TCLSH): $(TCLSHOBJS) $(TCLLIB) $(TMPDIR)\$(NAMEPREFIX)sh.res
+ $(link32) $(ldebug) -S:2400000 $(LNFLAGS) $(LNFLAGS_CONS) $(TOOLS32)\lib\c0x32 @&&!
+ $(TCLSHOBJS), $@, -x, $(LNLIBS) $(TCLLIB),, $(TMPDIR)\$(NAMEPREFIX)sh.res
+!
+
+$(TCLSHP): $(TCLSHOBJS) $(TCLPLUGINLIB) $(TMPDIR)\tclsh.res
+ $(link32) $(ldebug) $(conlflags) $(TMPDIR)\tclsh.res -stack:2300000 \
+ -out:$@ $(conlibsdll) $(TCLPLUGINLIB) $(TCLSHOBJS)
+
+$(TCLTEST): $(TCLTESTOBJS) $(TCLLIB) $(TMPDIR)\$(NAMEPREFIX)sh.res
+ $(link32) $(ldebug) -S:2400000 $(LNFLAGS) $(LNFLAGS_CONS) $(TOOLS32)\lib\c0x32 @&&!
+ $(TCLTESTOBJS), $@, -x, $(LNLIBS) $(TCLLIB),, $(TMPDIR)\$(NAMEPREFIX)sh.res
+!
+
+$(TCLDDEDLL): $(TMPDIR)\tclWinDde.obj $(TCLSTUBLIB)
+ $(link32) $(ldebug) $(LNFLAGS) $(LNFLAGS_DLL) $(TOOLS32)\lib\c0d32 \
+ $(TMPDIR)\tclWinDde.obj, $@, -x, $(LNLIBS) $(TCLSTUBLIB),, \
+ $(TMPDIR)\$(NAMEPREFIX).res
+
+$(TCLREGDLL): $(TMPDIR)\tclWinReg.obj $(TCLSTUBLIB)
+ $(link32) $(ldebug) $(LNFLAGS) $(LNFLAGS_DLL) $(TOOLS32)\lib\c0d32 \
+ $(TMPDIR)\tclWinReg.obj, $@, -x, $(LNLIBS) $(TCLSTUBLIB),, \
+ $(TMPDIR)\$(NAMEPREFIX).res
+
+$(CAT32): $(WINDIR)\cat.c
+ $(cc32) $(CONS_CFLAGS) -o$(TMPDIR)\cat.obj $?
+ $(link32) $(ldebug) $(LNFLAGS) $(LNFLAGS_CONS) $(TOOLS32)\lib\c0x32 \
+ $(TMPDIR)\cat.obj, $@, -x, $(LNLIBS),,
+
+install-binaries: $(TCLSH)
+ $(MKDIR) "$(BIN_INSTALL_DIR)"
+ $(MKDIR) "$(LIB_INSTALL_DIR)"
+ @echo Installing $(TCLDLLNAME)
+ @copy "$(TCLDLL)" "$(BIN_INSTALL_DIR)"
+ @copy "$(TCLLIB)" "$(LIB_INSTALL_DIR)"
+ @echo Installing "$(TCLSH)"
+ @copy "$(TCLSH)" "$(BIN_INSTALL_DIR)"
+ @echo Installing $(TCLSTUBLIBNAME)
+ @copy "$(TCLSTUBLIB)" "$(LIB_INSTALL_DIR)"
+ @echo Installing $(WINDIR)\tclooConfig.sh
+ @copy "$(WINDIR)\tclooConfig.sh" "$(LIB_INSTALL_DIR)"
+
+install-libraries:
+ -@$(MKDIR) "$(LIB_INSTALL_DIR)"
+ -@$(MKDIR) "$(INCLUDE_INSTALL_DIR)"
+ -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)"
+ @echo Installing http1.0
+ -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http1.0"
+ -@copy "$(ROOT)\library\http1.0\http.tcl" "$(SCRIPT_INSTALL_DIR)\http1.0"
+ -@copy "$(ROOT)\library\http1.0\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http1.0"
+ @echo Installing http2.8
+ -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http2.8"
+ -@copy "$(ROOT)\library\http\http.tcl" "$(SCRIPT_INSTALL_DIR)\http2.8"
+ -@copy "$(ROOT)\library\http\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http2.8"
+ @echo Installing opt0.4
+ -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\opt0.4"
+ -@copy "$(ROOT)\library\opt\optparse.tcl" "$(SCRIPT_INSTALL_DIR)\opt0.4"
+ -@copy "$(ROOT)\library\opt\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\opt0.4"
+ @echo Installing msgcat1.5
+ -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\msgcat1.5"
+ -@copy "$(ROOT)\library\msgcat\msgcat.tcl" "$(SCRIPT_INSTALL_DIR)\msgcat1.5"
+ -@copy "$(ROOT)\library\msgcat\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\msgcat1.5"
+ @echo Installing tcltest2.3
+ -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\tcltest2.3"
+ -@copy "$(ROOT)\library\tcltest\tcltest.tcl" "$(SCRIPT_INSTALL_DIR)\tcltest2.3"
+ -@copy "$(ROOT)\library\tcltest\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\tcltest2.3"
+ @echo Installing platform1.0
+ -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\platform1.0"
+ -@copy "$(ROOT)\library\platform\platform.tcl" "$(SCRIPT_INSTALL_DIR)\platform1.0"
+ -@copy "$(ROOT)\library\platform\shell.tcl" "$(SCRIPT_INSTALL_DIR)\platform1.0"
+ -@copy "$(ROOT)\library\platform\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\platform1.0"
+ @echo Installing $(TCLDDEDLLNAME)
+ -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\dde1.3"
+ -@copy "$(TCLDDEDLL)" "$(SCRIPT_INSTALL_DIR)\dde1.3"
+ -@copy "$(ROOT)\library\dde\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\dde1.3"
+ @echo Installing $(TCLREGDLLNAME)
+ -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\reg1.2"
+ -@copy "$(TCLREGDLL)" "$(SCRIPT_INSTALL_DIR)\reg1.3"
+ -@copy "$(ROOT)\library\reg\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\reg1.2"
+ @echo Installing encoding files
+ -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\encoding"
+ -@copy "$(ROOT)\library\encoding\*.enc" "$(SCRIPT_INSTALL_DIR)\encoding"
+ @echo Installing library files
+ -@copy "$(GENERICDIR)\tcl.h" "$(INCLUDE_INSTALL_DIR)"
+ -@copy "$(GENERICDIR)\tclDecls.h" "$(INCLUDE_INSTALL_DIR)"
+ -@copy "$(GENERICDIR)\tclOO.h" "$(INCLUDE_INSTALL_DIR)"
+ -@copy "$(GENERICDIR)\tclOODecls.h" "$(INCLUDE_INSTALL_DIR)"
+ -@copy "$(GENERICDIR)\tclPlatDecls.h" "$(INCLUDE_INSTALL_DIR)"
+ -@copy "$(ROOT)\library\history.tcl" "$(SCRIPT_INSTALL_DIR)"
+ -@copy "$(ROOT)\library\init.tcl" "$(SCRIPT_INSTALL_DIR)"
+ -@copy "$(ROOT)\library\parray.tcl" "$(SCRIPT_INSTALL_DIR)"
+ -@copy "$(ROOT)\library\safe.tcl" "$(SCRIPT_INSTALL_DIR)"
+ -@copy "$(ROOT)\library\tclIndex" "$(SCRIPT_INSTALL_DIR)"
+ -@copy "$(ROOT)\library\package.tcl" "$(SCRIPT_INSTALL_DIR)"
+ -@copy "$(ROOT)\library\word.tcl" "$(SCRIPT_INSTALL_DIR)"
+ -@copy "$(ROOT)\library\auto.tcl" "$(SCRIPT_INSTALL_DIR)"
+
+#
+# Regenerate the stubs files.
+#
+
+genstubs:
+ tclsh$(VERSION) $(ROOT)\tools\genStubs.tcl $(GENERICDIR) \
+ $(GENERICDIR)\tcl.decls $(GENERICDIR)\tclInt.decls
+
+#
+# Special case object file targets
+#
+$(TMPDIR)\tclWinInit.obj: $(WINDIR)\tclWinInit.c
+ $(cc32) -DBUILD_tcl $(TCL_CFLAGS) -o$(TMPDIR)\$@ $?
+
+$(TMPDIR)\testMain.obj: $(WINDIR)\tclAppInit.c
+ $(cc32) $(TCL_CFLAGS) -DTCL_TEST -o$(TMPDIR)\testMain.obj $?
+
+$(TMPDIR)\tclTest.obj: $(GENERICDIR)\tclTest.c
+ $(cc32) $(TCL_CFLAGS) -o$(TMPDIR)\$@ $?
+
+$(TMPDIR)\tclTestObj.obj: $(GENERICDIR)\tclTestObj.c
+ $(cc32) $(TCL_CFLAGS) -o$(TMPDIR)\$@ $?
+
+$(TMPDIR)\tclWinTest.obj: $(WINDIR)\tclWinTest.c
+ $(cc32) $(TCL_CFLAGS) -o$(TMPDIR)\$@ $?
+
+$(TMP_DIR)\tclPkgConfig.obj: $(GENERICDIR)\tclPkgConfig.c
+ $(cc32) $(TCL_CFLAGS) \
+ -DCFG_INSTALL_EXEC_PREFIX=\"$(INSTALL_EXEC_PREFIX)\" \
+ -DCFG_INSTALL_PREFIX=\"$(INSTALL_PREFIX)\" \
+ -DCFG_RUNTIME_EXEC_PREFIX=\"$(RUNTIME_EXEC_PREFIX)\" \
+ -DCFG_RUNTIME_PREFIX=\"$(RUNTIME_PREFIX)\" \
+ -o$(TMPDIR)\$@ $?
+
+$(TMPDIR)\tclAppInit.obj : $(WINDIR)\tclAppInit.c
+ $(cc32) $(TCL_CFLAGS) -o$(TMPDIR)\$@ $?
+
+# The following objects should be built using the stub interfaces
+
+# tclWinReg: Produces errors in ANSI mode
+$(TMPDIR)\tclWinReg.obj : $(WINDIR)\tclWinReg.c
+ $(cc32) $(TCL_CFLAGS) -DUSE_TCL_STUBS -o$(TMPDIR)\$@ $?
+
+# tclWinDde: Produces errors in ANSI mode
+$(TMPDIR)\tclWinDde.obj : $(WINDIR)\tclWinDde.c
+ $(cc32) $(TCL_CFLAGS) -DUSE_TCL_STUBS -o$(TMPDIR)\$@ $?
+
+
+# The following objects are part of the stub library and should not
+# be built as DLL objects but none of the symbols should be exported
+
+$(TMPDIR)\tclStubLib.obj : $(GENERICDIR)\tclStubLib.c
+ $(cc32) $(TCL_CFLAGS) -DSTATIC_BUILD -o$(TMPDIR)\$@ $?
+
+$(TMPDIR)\tclTomMathStubLib.obj : $(GENERICDIR)\tclTomMathStubLib.c
+ $(cc32) $(TCL_CFLAGS) -DSTATIC_BUILD -o$(TMPDIR)\$@ $?
+
+$(TMPDIR)\tclOOStubLib.obj : $(GENERICDIR)\tclOOStubLib.c
+ $(cc32) $(TCL_CFLAGS) -DSTATIC_BUILD -o$(TMPDIR)\$@ $?
+
+
+# Dedependency rules
+
+$(GENERICDIR)\regcomp.c: \
+ $(GENERICDIR)\regguts.h \
+ $(GENERICDIR)\regc_lex.c \
+ $(GENERICDIR)\regc_color.c \
+ $(GENERICDIR)\regc_nfa.c \
+ $(GENERICDIR)\regc_cvec.c \
+ $(GENERICDIR)\regc_locale.c
+
+$(GENERICDIR)\regcustom.h: \
+ $(GENERICDIR)\tclInt.h \
+ $(GENERICDIR)\tclPort.h \
+ $(GENERICDIR)\regex.h
+
+$(GENERICDIR)\regexec.c: \
+ $(GENERICDIR)\rege_dfa.c \
+ $(GENERICDIR)\regguts.h
+
+$(GENERICDIR)\regerror.c: $(GENERICDIR)\regguts.h
+$(GENERICDIR)\regfree.c: $(GENERICDIR)\regguts.h
+$(GENERICDIR)\regfronts.c: $(GENERICDIR)\regguts.h
+$(GENERICDIR)\regguts.h: $(GENERICDIR)\regcustom.h
+
+#
+# Implicit rules
+#
+
+{$(WINDIR)}.c{$(TMPDIR)}.obj:
+ $(cc32) -DBUILD_tcl $(TCL_CFLAGS) -o$@ $<
+
+{$(GENERICDIR)}.c{$(TMPDIR)}.obj:
+ $(cc32) -DBUILD_tcl $(TCL_CFLAGS) -o$@ $<
+
+{$(ROOT)\compat}.c{$(TMPDIR)}.obj:
+ $(cc32) -DBUILD_tcl $(TCL_CFLAGS) -o$@ $<
+
+{$(WINDIR)}.rc{$(TMPDIR)}.res:
+ $(rc32) $(INCLUDEPATH) -D$(USERDEFINES);$(SYSDEFINES) -fo$@ $<
+
+clean:
+ -@$(RM) $(OUTDIR)\*.exp
+ -@$(RM) $(OUTDIR)\*.lib
+ -@$(RM) $(OUTDIR)\*.dll
+ -@$(RM) $(OUTDIR)\*.exe
+ -@$(RM) $(OUTDIR)\*.pdb
+ -@$(RM) $(TMPDIR)\*.pch
+ -@$(RM) $(TMPDIR)\*.obj
+ -@$(RM) $(TMPDIR)\*.res
+ -@$(RM) $(TMPDIR)\*.exe
+ -@$(RMDIR) $(OUTDIR)
+ -@$(RMDIR) $(TMPDIR)
+
+# Local Variables:
+# mode: makefile
+# End:
diff --git a/win/makefile.vc b/win/makefile.vc
new file mode 100644
index 0000000..8526203
--- /dev/null
+++ b/win/makefile.vc
@@ -0,0 +1,1242 @@
+#-------------------------------------------------------------
+# 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 compatability.
+#
+# 64bit = Enable 64bit portability warnings (if available)
+# fullwarn = Builds with full compiler and link warnings enabled.
+# Very verbose.
+# nodep = Turns off compatability macros to ensure the core
+# isn't being built with deprecated functions.
+#
+# MACHINE=(ALPHA|AMD64|IA64|IX86)
+# Set the machine type used for the compiler, linker, and
+# resource compiler. This hook is needed to tell the tools
+# when alternate platforms are requested. IX86 is the default
+# when not specified. If the CPU environment variable has been
+# set (ie: recent Platform SDK) then MACHINE is set from CPU.
+#
+# 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_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_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
+
+### Declarations common to all compiler options
+cwarn = $(WARNINGS) -D _CRT_SECURE_NO_DEPRECATE -D _CRT_NONSTDC_NO_DEPRECATE
+cflags = -nologo -c $(COMPILERFLAGS) $(cwarn) -Fp$(TMP_DIR)^\
+
+!if $(MSVCRT)
+!if $(DEBUG) && !$(UNCHECKED)
+crt = -MDd
+!else
+crt = -MD
+!endif
+!else
+!if $(DEBUG) && !$(UNCHECKED)
+crt = -MTd
+!else
+crt = -MT
+!endif
+!endif
+
+TCL_INCLUDES = -I"$(WINDIR)" -I"$(GENERICDIR)" -I"$(TOMMATHDIR)"
+TCL_DEFINES = -DTCL_TOMMATH -DMP_PREC=4 -Dinline=__inline -DHAVE_ZLIB=1
+BASE_CFLAGS = $(cflags) $(cdebug) $(crt) $(TCL_INCLUDES) $(TCL_DEFINES)
+CON_CFLAGS = $(cflags) $(cdebug) $(crt) -DCONSOLE
+TCL_CFLAGS = $(BASE_CFLAGS) $(OPTDEFINES)
+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_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)\_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..84cf75c
--- /dev/null
+++ b/win/nmakehlp.c
@@ -0,0 +1,697 @@
+/*
+ * ----------------------------------------------------------------------------
+ * 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 *option);
+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>\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]);
+ 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 *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 = 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.
+ */
+
+ lstrcat(cmdline, option);
+
+ 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);
+}
+
+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..e12854d
--- /dev/null
+++ b/win/rules.vc
@@ -0,0 +1,703 @@
+#------------------------------------------------------------------------------
+# 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
+
+!if "$(MACHINE)" == "IX86"
+### test for -align:4096, when align:512 will do.
+!if [nmakehlp -l -opt:nowin98]
+!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]
+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]
+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]
+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]
+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..9ea990b
--- /dev/null
+++ b/win/tcl.dsp
@@ -0,0 +1,1567 @@
+# 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\tclsh85.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\tclsh85t.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\tclsh85g.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\tclsh85tg.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\tclsh85sg.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\tclsh85sg.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\tclsh85s.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\tclsh85s.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.bc
+# 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..7eff8e8
--- /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 -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..e06eaf5
--- /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..b060370
--- /dev/null
+++ b/win/tclConfig.sh.in
@@ -0,0 +1,180 @@
+# 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 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_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..e4adb1d
--- /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)
+#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;
+
+# else
+ /*
+ * 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..7518e3e
--- /dev/null
+++ b/win/tclWinChan.c
@@ -0,0 +1,1588 @@
+/*
+ * 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. */
+};
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 (!(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 (!(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 && !(infoPtr->flags & FILE_PENDING)) {
+ 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 (!(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) {
+ 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) {
+ infoPtr->flags |= FILE_ASYNC;
+ } else {
+ 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 (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 (direction & infoPtr->validMask) {
+ *handlePtr = (ClientData) infoPtr->handle;
+ return TCL_OK;
+ } else {
+ return TCL_ERROR;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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_Interp *) NULL) {
+ Tcl_AppendResult(interp, "couldn't open \"",
+ TclGetString(pathPtr), "\": filename is invalid on this platform",
+ NULL);
+ }
+ 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_Interp *) NULL) {
+ Tcl_AppendResult(interp, "couldn't open serial \"",
+ TclGetString(pathPtr), "\": ",
+ Tcl_PosixError(interp), NULL);
+ }
+ 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 (mode & O_CREAT) {
+ if (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 = (mode & O_CREAT) ? ERROR_FILE_EXISTS : ERROR_FILE_NOT_FOUND;
+ }
+ TclWinConvertError(err);
+ if (interp != (Tcl_Interp *) NULL) {
+ 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_Interp *) NULL) {
+ 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 (channelPermissions & TCL_READABLE) {
+ readFile = TclWinMakeFile(handle);
+ }
+ if (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, (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 (mode & TCL_READABLE) {
+ readFile = TclWinMakeFile(handle);
+ }
+ if (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..5ce8a2b
--- /dev/null
+++ b/win/tclWinConsole.c
@@ -0,0 +1,1502 @@
+/*
+ * 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. */
+ HANDLE startEvent; /* Auto-reset event used by the main thread to
+ * signal when the thread should attempt to do
+ * its normal work. */
+ HANDLE stopEvent; /* Auto-reset event used by the main thread to
+ * signal when the thread should exit. */
+} ConsoleThreadInfo;
+
+/*
+ * This structure describes per-instance data for a console based channel.
+ */
+
+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 start event is sent,
+ * and a reset event is sent back to the main
+ * thread when the write is done. A stop event
+ * is used to terminate the thread. */
+ ConsoleThreadInfo reader; /* A specialized thread for handling
+ * asynchronous reads from the console; the
+ * waiting starts when a start event is sent,
+ * and a reset event is sent back to the main
+ * thread when input is available. A stop
+ * event is used to terminate the thread. */
+ DWORD writeError; /* An error caused by the last background
+ * write. Set to 0 if no error has been
+ * detected. This word is shared with the
+ * 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);
+static void StartChannelThread(ConsoleInfo *infoPtr,
+ ConsoleThreadInfo *threadInfoPtr,
+ LPTHREAD_START_ROUTINE threadProc);
+static void StopChannelThread(ConsoleThreadInfo *threadInfoPtr);
+
+/*
+ * This structure describes the channel type structure for command console
+ * based IO.
+ */
+
+static const Tcl_ChannelType consoleChannelType = {
+ "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;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * StartChannelThread, StopChannelThread --
+ *
+ * Helpers that codify how to ask one of the console service threads to
+ * start and stop.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+StartChannelThread(
+ ConsoleInfo *infoPtr,
+ ConsoleThreadInfo *threadInfoPtr,
+ LPTHREAD_START_ROUTINE threadProc)
+{
+ DWORD id;
+
+ threadInfoPtr->readyEvent = CreateEvent(NULL, TRUE, TRUE, NULL);
+ threadInfoPtr->startEvent = CreateEvent(NULL, FALSE, FALSE, NULL);
+ threadInfoPtr->stopEvent = CreateEvent(NULL, FALSE, FALSE, NULL);
+ threadInfoPtr->thread = CreateThread(NULL, 256, threadProc, infoPtr, 0,
+ &id);
+ SetThreadPriority(threadInfoPtr->thread, THREAD_PRIORITY_HIGHEST);
+}
+
+static void
+StopChannelThread(
+ ConsoleThreadInfo *threadInfoPtr)
+{
+ DWORD exitCode = 0;
+
+ /*
+ * The thread may already have closed on it's own. Check it's exit
+ * code.
+ */
+
+ GetExitCodeThread(threadInfoPtr->thread, &exitCode);
+ if (exitCode == STILL_ACTIVE) {
+ /*
+ * Set the stop event so that if the reader thread is blocked in
+ * ConsoleReaderThread on WaitForMultipleEvents, it will exit cleanly.
+ */
+
+ SetEvent(threadInfoPtr->stopEvent);
+
+ /*
+ * Wait at most 20 milliseconds for the reader thread to close.
+ */
+
+ if (WaitForSingleObject(threadInfoPtr->thread, 20) == WAIT_TIMEOUT) {
+ /*
+ * Forcibly terminate the background thread as a last resort.
+ * Note that we need to guard against terminating the thread while
+ * it is in the middle of Tcl_ThreadAlert because it won't be able
+ * to release the notifier lock.
+ */
+
+ Tcl_MutexLock(&consoleMutex);
+ /* BUG: this leaks memory. */
+ TerminateThread(threadInfoPtr->thread, 0);
+ Tcl_MutexUnlock(&consoleMutex);
+ }
+ }
+
+ /*
+ * Close all the handles associated with the thread, and set the thread
+ * handle field to NULL to mark that the thread has been cleaned up.
+ */
+
+ CloseHandle(threadInfoPtr->thread);
+ CloseHandle(threadInfoPtr->readyEvent);
+ CloseHandle(threadInfoPtr->startEvent);
+ CloseHandle(threadInfoPtr->stopEvent);
+ threadInfoPtr->thread = NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ConsoleCloseProc --
+ *
+ * Closes a console based IO channel.
+ *
+ * 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) {
+ StopChannelThread(&consolePtr->reader);
+ }
+ 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, INFINITE);
+ }
+
+ StopChannelThread(&consolePtr->writer);
+ }
+ consolePtr->validMask &= ~TCL_WRITABLE;
+
+ /*
+ * Don't close the Win32 handle if the handle is a standard channel during
+ * the thread exit process. Otherwise, one thread may kill the stdio of
+ * 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->reader;
+ DWORD bytesWritten, timeout;
+
+ *errorCode = 0;
+ timeout = (infoPtr->flags & CONSOLE_ASYNC) ? 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);
+ SetEvent(threadInfo->startEvent);
+ 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.
+ */
+
+ timeout = blocking ? INFINITE : 0;
+ 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);
+ SetEvent(threadInfo->startEvent);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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)
+{
+ ConsoleInfo *infoPtr = arg;
+ HANDLE *handle = infoPtr->handle;
+ ConsoleThreadInfo *threadInfo = &infoPtr->reader;
+ DWORD waitResult;
+ HANDLE wEvents[2];
+
+ /*
+ * The first event takes precedence.
+ */
+
+ wEvents[0] = threadInfo->stopEvent;
+ wEvents[1] = threadInfo->startEvent;
+
+ for (;;) {
+ /*
+ * Wait for the main thread to signal before attempting to wait.
+ */
+
+ waitResult = WaitForMultipleObjects(2, wEvents, FALSE, INFINITE);
+
+ if (waitResult != (WAIT_OBJECT_0 + 1)) {
+ /*
+ * The start event was not signaled. It must be the stop event or
+ * an error, so exit this thread.
+ */
+
+ break;
+ }
+
+ /*
+ * 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;
+ }
+ }
+
+ /*
+ * 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);
+ }
+
+ 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)
+{
+ ConsoleInfo *infoPtr = arg;
+ HANDLE *handle = infoPtr->handle;
+ ConsoleThreadInfo *threadInfo = &infoPtr->writer;
+ DWORD count, toWrite, waitResult;
+ char *buf;
+ HANDLE wEvents[2];
+
+ /*
+ * The first event takes precedence.
+ */
+
+ wEvents[0] = threadInfo->stopEvent;
+ wEvents[1] = threadInfo->startEvent;
+
+ for (;;) {
+ /*
+ * Wait for the main thread to signal before attempting to write.
+ */
+
+ waitResult = WaitForMultipleObjects(2, wEvents, FALSE, INFINITE);
+
+ if (waitResult != (WAIT_OBJECT_0 + 1)) {
+ /*
+ * The start event was not signaled. It must be the stop event or
+ * an error, so exit this thread.
+ */
+
+ break;
+ }
+
+ 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();
+ 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);
+ }
+
+ 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);
+ StartChannelThread(infoPtr, &infoPtr->reader, ConsoleReaderThread);
+ }
+
+ if (permissions & TCL_WRITABLE) {
+ StartChannelThread(infoPtr, &infoPtr->writer, ConsoleWriterThread);
+ }
+
+ /*
+ * 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..8904a05
--- /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.
+ */
+
+ int len;
+ const char *str = TclGetStringFromObj(fileName,&len);
+
+ 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;
+ int pathLen;
+
+ Tcl_ListObjIndex(NULL, splitPath, i, &elt);
+
+ pathv = TclGetStringFromObj(elt, &pathLen);
+ 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;
+ int tempLen;
+ 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 = TclGetStringFromObj(tempPath,&tempLen);
+ nativeName = Tcl_WinUtfToTChar(tempString, tempLen, &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 100755
index 0000000..9458933
--- /dev/null
+++ b/win/tclWinFile.c
@@ -0,0 +1,3204 @@
+/*
+ * 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, int 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)
+ _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.
+ */
+
+ int len;
+ DWORD attr;
+ WIN32_FILE_ATTRIBUTE_DATA data;
+ const char *str = TclGetStringFromObj(norm,&len);
+
+ native = Tcl_FSGetNativePath(pathPtr);
+
+ if (GetFileAttributesEx(native,
+ GetFileExInfoStandard, &data) != TRUE) {
+ return TCL_OK;
+ }
+ attr = data.dwFileAttributes;
+
+ if (NativeMatchType(WinIsDrive(str,len), attr, native, types)) {
+ Tcl_ListObjAppendElement(interp, resultPtr, pathPtr);
+ }
+ }
+ return TCL_OK;
+ } else {
+ DWORD attr;
+ HANDLE handle;
+ WIN32_FIND_DATA data;
+ const char *dirName; /* UTF-8 dir name, later with pattern
+ * appended. */
+ int 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 = TclGetStringFromObj(fileNamePtr, &dirLength);
+ 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) */
+ int 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.
+ */
+
+ int len;
+ char *path;
+ Tcl_Obj *tmpPathPtr;
+
+ tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),
+ nextCheckpoint);
+ Tcl_AppendToObj(tmpPathPtr, lastValidPathEnd, -1);
+ path = TclGetStringFromObj(tmpPathPtr, &len);
+ Tcl_SetStringObj(pathPtr, path, len);
+ 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.
+ */
+
+ int cwdLen;
+ const char *drive =
+ TclGetStringFromObj(useThisCwd, &cwdLen);
+ 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..d2ee7e1
--- /dev/null
+++ b/win/tclWinInit.c
@@ -0,0 +1,722 @@
+/*
+ * 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
+
+/*
+ * 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);
+
+ 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
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * 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) {
+ HANDLE handle = LoadLibraryW(L"NTDLL");
+ int(__stdcall *getversion)(void *) =
+ (int(__stdcall *)(void *)) GetProcAddress(handle, "RtlGetVersion");
+ osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
+ if (!getversion || getversion(&osInfo)) {
+ GetVersionExW(&osInfo);
+ }
+ if (handle) {
+ FreeLibrary(handle);
+ }
+ 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..6b098f8
--- /dev/null
+++ b/win/tclWinInt.h
@@ -0,0 +1,89 @@
+/*
+ * 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
+
+/*
+ * 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
+
+#endif /* _TCLWININT */
diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c
new file mode 100644
index 0000000..26512b1
--- /dev/null
+++ b/win/tclWinLoad.c
@@ -0,0 +1,402 @@
+/*
+ * 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;
+
+ /*
+ * 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;
+
+ 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 = GetLastError();
+ Tcl_Obj *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;
+ 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(&notifierMutex);
+ }
+ TclpMasterUnlock();
+
+ /*
+ * Register Notifier window class if this is the first thread to use
+ * this module.
+ */
+
+ EnterCriticalSection(&notifierMutex);
+ 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(&notifierMutex);
+
+ 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(&notifierMutex);
+ if (notifierCount) {
+ notifierCount--;
+ if (notifierCount == 0) {
+ UnregisterClass(className, TclWinGetTclInstance());
+ }
+ }
+ LeaveCriticalSection(&notifierMutex);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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..4666deb
--- /dev/null
+++ b/win/tclWinPipe.c
@@ -0,0 +1,3167 @@
+/*
+ * 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. */
+ HANDLE writeThread; /* Handle to writer thread. */
+ HANDLE readThread; /* Handle to reader thread. */
+ HANDLE writable; /* Manual-reset event to signal when the
+ * writer thread has finished waiting for the
+ * current buffer to be written. */
+ HANDLE readable; /* Manual-reset event to signal when the
+ * reader thread has finished waiting for
+ * input. */
+ HANDLE startWriter; /* Auto-reset event used by the main thread to
+ * signal when the writer thread should
+ * attempt to write to the pipe. */
+ HANDLE stopWriter; /* Manual-reset event used to alert the reader
+ * thread to fall-out and exit */
+ HANDLE startReader; /* Auto-reset event used by the main thread to
+ * signal when the reader thread should
+ * attempt to read from the pipe. */
+ HANDLE stopReader; /* Manual-reset event used to alert the reader
+ * thread to fall-out and exit */
+ DWORD writeError; /* An error caused by the last background
+ * write. Set to 0 if no error has been
+ * detected. This word is shared with the
+ * 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;
+
+ for (start = arg; *start != '\0'; start += count) {
+ count = Tcl_UtfToUniChar(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];
+ DWORD id;
+ 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->startReader = CreateEvent(NULL, FALSE, FALSE, NULL);
+ infoPtr->stopReader = CreateEvent(NULL, TRUE, FALSE, NULL);
+ infoPtr->readThread = CreateThread(NULL, 256, PipeReaderThread,
+ infoPtr, 0, &id);
+ SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST);
+ infoPtr->validMask |= TCL_READABLE;
+ } else {
+ infoPtr->readThread = 0;
+ }
+ if (writeFile != NULL) {
+ /*
+ * Start the background writer thread.
+ */
+
+ infoPtr->writable = CreateEvent(NULL, TRUE, TRUE, NULL);
+ infoPtr->startWriter = CreateEvent(NULL, FALSE, FALSE, NULL);
+ infoPtr->stopWriter = CreateEvent(NULL, TRUE, FALSE, NULL);
+ infoPtr->writeThread = CreateThread(NULL, 256, PipeWriterThread,
+ infoPtr, 0, &id);
+ SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST);
+ infoPtr->validMask |= TCL_WRITABLE;
+ }
+
+ /*
+ * 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);
+ DWORD exitCode;
+
+ 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) {
+ /*
+ * The thread may already have closed on its own. Check its exit
+ * code.
+ */
+
+ GetExitCodeThread(pipePtr->readThread, &exitCode);
+
+ if (exitCode == STILL_ACTIVE) {
+ /*
+ * Set the stop event so that if the reader thread is blocked
+ * in PipeReaderThread on WaitForMultipleEvents, it will exit
+ * cleanly.
+ */
+
+ SetEvent(pipePtr->stopReader);
+
+ /*
+ * Wait at most 20 milliseconds for the reader thread to
+ * close.
+ */
+
+ if (WaitForSingleObject(pipePtr->readThread,
+ 20) == WAIT_TIMEOUT) {
+ /*
+ * The thread must be blocked waiting for the pipe to
+ * become readable in ReadFile(). There isn't a clean way
+ * to exit the thread from this condition. We should
+ * terminate the child process instead to get the reader
+ * thread to fall out of ReadFile with a FALSE. (below) is
+ * not the correct way to do this, but will stay here
+ * until a better solution is found.
+ *
+ * Note that we need to guard against terminating the
+ * thread while it is in the middle of Tcl_ThreadAlert
+ * because it won't be able to release the notifier lock.
+ */
+
+ Tcl_MutexLock(&pipeMutex);
+
+ /* BUG: this leaks memory */
+ TerminateThread(pipePtr->readThread, 0);
+ Tcl_MutexUnlock(&pipeMutex);
+ }
+ }
+
+ CloseHandle(pipePtr->readThread);
+ CloseHandle(pipePtr->readable);
+ CloseHandle(pipePtr->startReader);
+ CloseHandle(pipePtr->stopReader);
+ 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 but blocked during exit, bail out since the worker
+ * thread is not interruptible and we want TIP#398-fast-exit.
+ */
+ if (TclInExit()
+ && (pipePtr->flags & PIPE_ASYNC)) {
+
+ /* give it a chance to leave honorably */
+ SetEvent(pipePtr->stopWriter);
+
+ if (WaitForSingleObject(pipePtr->writable, 0) == WAIT_TIMEOUT) {
+ return EWOULDBLOCK;
+ }
+
+ } else {
+
+ WaitForSingleObject(pipePtr->writable, INFINITE);
+
+ }
+
+ /*
+ * The thread may already have closed on it's own. Check its exit
+ * code.
+ */
+
+ GetExitCodeThread(pipePtr->writeThread, &exitCode);
+
+ if (exitCode == STILL_ACTIVE) {
+ /*
+ * Set the stop event so that if the reader thread is blocked
+ * in PipeReaderThread on WaitForMultipleEvents, it will exit
+ * cleanly.
+ */
+
+ SetEvent(pipePtr->stopWriter);
+
+ /*
+ * Wait at most 20 milliseconds for the reader thread to
+ * close.
+ */
+
+ if (WaitForSingleObject(pipePtr->writeThread,
+ 20) == WAIT_TIMEOUT) {
+ /*
+ * The thread must be blocked waiting for the pipe to
+ * consume input in WriteFile(). There isn't a clean way
+ * to exit the thread from this condition. We should
+ * terminate the child process instead to get the writer
+ * thread to fall out of WriteFile with a FALSE. (below)
+ * is not the correct way to do this, but will stay here
+ * until a better solution is found.
+ *
+ * Note that we need to guard against terminating the
+ * thread while it is in the middle of Tcl_ThreadAlert
+ * because it won't be able to release the notifier lock.
+ */
+
+ Tcl_MutexLock(&pipeMutex);
+
+ /* BUG: this leaks memory */
+ TerminateThread(pipePtr->writeThread, 0);
+ Tcl_MutexUnlock(&pipeMutex);
+ }
+ }
+
+ CloseHandle(pipePtr->writeThread);
+ CloseHandle(pipePtr->writable);
+ CloseHandle(pipePtr->startWriter);
+ CloseHandle(pipePtr->stopWriter);
+ 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) || TclInExit()) {
+ /*
+ * 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;
+ timeout = (infoPtr->flags & PIPE_ASYNC) ? 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);
+ SetEvent(infoPtr->startWriter);
+ 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.
+ */
+
+ timeout = blocking ? INFINITE : 0;
+ 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);
+ SetEvent(infoPtr->startReader);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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)
+{
+ PipeInfo *infoPtr = (PipeInfo *)arg;
+ HANDLE *handle = ((WinFile *) infoPtr->readFile)->handle;
+ DWORD count, err;
+ int done = 0;
+ HANDLE wEvents[2];
+ DWORD waitResult;
+
+ wEvents[0] = infoPtr->stopReader;
+ wEvents[1] = infoPtr->startReader;
+
+ while (!done) {
+ /*
+ * Wait for the main thread to signal before attempting to wait on the
+ * pipe becoming readable.
+ */
+
+ waitResult = WaitForMultipleObjects(2, wEvents, FALSE, INFINITE);
+
+ if (waitResult != (WAIT_OBJECT_0 + 1)) {
+ /*
+ * The start event was not signaled. It might be the stop event or
+ * an error, so exit.
+ */
+
+ break;
+ }
+
+ /*
+ * 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) {
+ break;
+ }
+ } 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) {
+ break;
+ }
+ }
+ }
+
+
+ /*
+ * 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);
+ }
+
+ 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)
+{
+ PipeInfo *infoPtr = (PipeInfo *)arg;
+ HANDLE *handle = ((WinFile *) infoPtr->writeFile)->handle;
+ DWORD count, toWrite;
+ char *buf;
+ int done = 0;
+ HANDLE wEvents[2];
+ DWORD waitResult;
+
+ wEvents[0] = infoPtr->stopWriter;
+ wEvents[1] = infoPtr->startWriter;
+
+ while (!done) {
+ /*
+ * Wait for the main thread to signal before attempting to write.
+ */
+
+ waitResult = WaitForMultipleObjects(2, wEvents, FALSE, INFINITE);
+
+ if (waitResult != (WAIT_OBJECT_0 + 1)) {
+ /*
+ * The start event was not signaled. It might be the stop event or
+ * an error, so exit.
+ */
+
+ if (waitResult == WAIT_OBJECT_0) {
+ SetEvent(infoPtr->writable);
+ }
+
+ break;
+ }
+
+ 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);
+ }
+
+ 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;
+}
+
+/*
+ * 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..5f7fd31
--- /dev/null
+++ b/win/tclWinReg.c
@@ -0,0 +1,1547 @@
+/*
+ * 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) {
+ HINSTANCE dllH;
+
+ checkExProc = 1;
+ dllH = LoadLibrary(TEXT("advapi32.dll"));
+ if (dllH) {
+ regDeleteKeyExProc = (FARPROC)
+ GetProcAddress(dllH, "RegDeleteKeyExW");
+ }
+ }
+ if (mode && regDeleteKeyExProc) {
+ result = regDeleteKeyExProc(startKey, keyName, mode, 0);
+ } else {
+ result = RegDeleteKey(startKey, keyName);
+ }
+ break;
+ } else if (result == ERROR_SUCCESS) {
+ result = RecursiveDeleteKey(hKey,
+ (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..0ce5f4d
--- /dev/null
+++ b/win/tclWinSerial.c
@@ -0,0 +1,2297 @@
+/*
+ * 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 */
+ HANDLE writeThread; /* Handle to writer thread. */
+ CRITICAL_SECTION csWrite; /* Writer thread synchronisation. */
+ HANDLE evWritable; /* Manual-reset event to signal when the
+ * writer thread has finished waiting for the
+ * current buffer to be written. */
+ HANDLE evStartWriter; /* Auto-reset event used by the main thread to
+ * signal when the writer thread should
+ * attempt to write to the serial. */
+ HANDLE evStopWriter; /* Auto-reset event used by the main thread to
+ * signal when the writer thread should close.
+ */
+ DWORD writeError; /* An error caused by the last background
+ * write. Set to 0 if no error has been
+ * detected. This word is shared with the
+ * 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);
+ DWORD exitCode;
+
+ errorCode = 0;
+
+ if (serialPtr->validMask & TCL_READABLE) {
+ PurgeComm(serialPtr->handle, PURGE_RXABORT | PURGE_RXCLEAR);
+ CloseHandle(serialPtr->osRead.hEvent);
+ }
+ serialPtr->validMask &= ~TCL_READABLE;
+
+ if (serialPtr->validMask & TCL_WRITABLE) {
+ /*
+ * Generally we cannot wait for a pending write operation because it
+ * may hang due to handshake
+ * WaitForSingleObject(serialPtr->evWritable, INFINITE);
+ */
+
+ /*
+ * The thread may have already closed on it's own. Check it's exit
+ * code.
+ */
+
+ GetExitCodeThread(serialPtr->writeThread, &exitCode);
+
+ if (exitCode == STILL_ACTIVE) {
+ /*
+ * Set the stop event so that if the writer thread is blocked in
+ * SerialWriterThread on WaitForMultipleEvents, it will exit
+ * cleanly.
+ */
+
+ SetEvent(serialPtr->evStopWriter);
+
+ /*
+ * Wait at most 20 milliseconds for the writer thread to close.
+ */
+
+ if (WaitForSingleObject(serialPtr->writeThread,
+ 20) == WAIT_TIMEOUT) {
+ /*
+ * Forcibly terminate the background thread as a last resort.
+ * Note that we need to guard against terminating the thread
+ * while it is in the middle of Tcl_ThreadAlert because it
+ * won't be able to release the notifier lock.
+ */
+
+ Tcl_MutexLock(&serialMutex);
+
+ /* BUG: this leaks memory */
+ TerminateThread(serialPtr->writeThread, 0);
+
+ Tcl_MutexUnlock(&serialMutex);
+ }
+ }
+
+ CloseHandle(serialPtr->writeThread);
+ CloseHandle(serialPtr->osWrite.hEvent);
+ CloseHandle(serialPtr->evWritable);
+ CloseHandle(serialPtr->evStartWriter);
+ CloseHandle(serialPtr->evStopWriter);
+ 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);
+ SetEvent(infoPtr->evStartWriter);
+ 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)
+{
+ SerialInfo *infoPtr = (SerialInfo *)arg;
+ DWORD bytesWritten, toWrite, waitResult;
+ char *buf;
+ OVERLAPPED myWrite; /* Have an own OVERLAPPED in this thread. */
+ HANDLE wEvents[2];
+
+ /*
+ * The stop event takes precedence by being first in the list.
+ */
+
+ wEvents[0] = infoPtr->evStopWriter;
+ wEvents[1] = infoPtr->evStartWriter;
+
+ for (;;) {
+ /*
+ * Wait for the main thread to signal before attempting to write.
+ */
+
+ waitResult = WaitForMultipleObjects(2, wEvents, FALSE, INFINITE);
+
+ if (waitResult != (WAIT_OBJECT_0 + 1)) {
+ /*
+ * The start event was not signaled. It might be the stop event or
+ * an error, so exit.
+ */
+
+ break;
+ }
+
+ 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);
+ }
+
+ 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;
+ DWORD id;
+
+ 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->evStartWriter = CreateEvent(NULL, FALSE, FALSE, NULL);
+ infoPtr->evStopWriter = CreateEvent(NULL, FALSE, FALSE, NULL);
+ infoPtr->writeThread = CreateThread(NULL, 256, SerialWriterThread,
+ infoPtr, 0, &id);
+ }
+
+ /*
+ * 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..ec881d2
--- /dev/null
+++ b/win/tclWinSock.c
@@ -0,0 +1,3367 @@
+/*
+ * 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))
+
+/* "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. */
+ 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 */
+
+/*
+ * 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};
+
+/*
+ * 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) {
+ statePtr->flags |= TCP_NONBLOCKING;
+ } else {
+ 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 && (statePtr->flags & TCP_ASYNC_FAILED)) {
+ *errorCodePtr = ENOTCONN;
+ return -1;
+ }
+
+ /*
+ * Check if an async connect is running. If not return ok
+ */
+
+ if (!(statePtr->flags & TCP_ASYNC_CONNECT)) {
+ return 0;
+ }
+
+ /*
+ * 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 statePtr lock */
+ tsdPtr = TclThreadDataKeyGet(&dataKey);
+ WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
+
+ /* Check for connect event */
+ if (statePtr->readyEvents & FD_CONNECT) {
+
+ /* Consume the connect event */
+ statePtr->readyEvents &= ~(FD_CONNECT);
+
+ /*
+ * For blocking sockets and foreground processing
+ * disable async connect as we continue now synchoneously
+ */
+ if ( errorCodePtr != NULL &&
+ ! (statePtr->flags & TCP_NONBLOCKING) ) {
+ CLEAR_BITS(statePtr->flags, TCP_ASYNC_CONNECT);
+ }
+
+ /* Free list lock */
+ SetEvent(tsdPtr->socketListLock);
+
+ /*
+ * Continue connect.
+ * If switched to synchroneous connect, the connect is terminated.
+ */
+ result = TcpConnect(NULL, statePtr);
+
+ /* Restore event service mode */
+ (void) Tcl_SetServiceMode(oldMode);
+
+ /*
+ * Check for Succesfull connect or async connect restart
+ */
+
+ if (result == TCL_OK) {
+ /*
+ * Check for async connect restart
+ * (not possible for foreground blocking operation)
+ */
+ if ( statePtr->flags & TCP_ASYNC_PENDING ) {
+ if (errorCodePtr != NULL) {
+ *errorCodePtr = EWOULDBLOCK;
+ }
+ return -1;
+ }
+ return 0;
+ }
+
+ /*
+ * Connect finally failed.
+ * For foreground operation return ENOTCONN.
+ */
+
+ if (errorCodePtr != NULL) {
+ *errorCodePtr = ENOTCONN;
+ }
+ return -1;
+ }
+
+ /* Free list lock */
+ SetEvent(tsdPtr->socketListLock);
+
+ /*
+ * Background operation returns with no action as there was no connect
+ * event
+ */
+
+ if ( errorCodePtr == NULL ) {
+ return -1;
+ }
+
+ /*
+ * A non blocking socket waiting for an asyncronous connect
+ * returns directly the error EWOULDBLOCK
+ */
+
+ if (statePtr->flags & TCP_NONBLOCKING) {
+ *errorCodePtr = EWOULDBLOCK;
+ return -1;
+ }
+
+ /*
+ * 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 (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) {
+ SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
+ (WPARAM) UNSELECT, (LPARAM) statePtr);
+ /* single fd operation: this proc is only called for a connected socket. */
+ bytesRead = recv(statePtr->sockets->fd, buf, bufSize, 0);
+ statePtr->readyEvents &= ~(FD_READ);
+
+ /*
+ * Check for end-of-file condition or successful read.
+ */
+
+ if (bytesRead == 0) {
+ 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 (statePtr->readyEvents & FD_CLOSE) {
+ 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) {
+ statePtr->flags |= SOCKET_EOF;
+ bytesRead = 0;
+ break;
+ }
+
+ /*
+ * Check for error condition or underflow in non-blocking case.
+ */
+
+ if ((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;
+ }
+ }
+
+ SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)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) {
+ SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
+ (WPARAM) UNSELECT, (LPARAM) statePtr);
+
+ /* single fd operation: this proc is only called for a connected socket. */
+ written = send(statePtr->sockets->fd, buf, toWrite, 0);
+ if (written != SOCKET_ERROR) {
+ /*
+ * Since Windows won't generate a new write event until we hit an
+ * overflow condition, we need to force the event loop to poll
+ * until the condition changes.
+ */
+
+ if (statePtr->watchEvents & FD_WRITE) {
+ Tcl_Time blockTime = { 0, 0 };
+ Tcl_SetMaxBlockTime(&blockTime);
+ }
+ break;
+ }
+
+ /*
+ * Check for error condition or overflow. In the event of overflow, we
+ * need to clear the FD_WRITE flag so we can detect the next writable
+ * event. Note that Windows only sends a new writable event after a
+ * send fails with WSAEWOULDBLOCK.
+ */
+
+ error = WSAGetLastError();
+ if (error == WSAEWOULDBLOCK) {
+ statePtr->readyEvents &= ~(FD_WRITE);
+ if (statePtr->flags & TCP_NONBLOCKING) {
+ *errorCodePtr = EWOULDBLOCK;
+ written = -1;
+ break;
+ }
+ } else {
+ TclWinConvertError(error);
+ *errorCodePtr = Tcl_GetErrno();
+ written = -1;
+ break;
+ }
+
+ /*
+ * In the blocking case, wait until the file becomes writable or
+ * closed and try again.
+ */
+
+ if (!WaitForSocketEvent(statePtr, FD_WRITE|FD_CLOSE, errorCodePtr)) {
+ written = -1;
+ break;
+ }
+ }
+
+ SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)statePtr);
+
+ return written;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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
+ */
+ 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 ( ! (statePtr->flags & TCP_ASYNC_PENDING) ) {
+
+
+ if ( 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;
+
+ /*
+ * Populater the err Variable with a possix error
+ */
+ optlen = sizeof(int);
+ ret = getsockopt(sock, SOL_SOCKET, SO_ERROR,
+ (char *)&err, &optlen);
+ /*
+ * The error was not returned directly but should be
+ * taken from WSA
+ */
+ if (ret == SOCKET_ERROR) {
+ err = WSAGetLastError();
+ }
+ /*
+ * Return error message
+ */
+ if (err) {
+ TclWinConvertError(err);
+ Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(Tcl_GetErrno()), -1);
+ }
+ }
+ }
+ return TCL_OK;
+ }
+
+ if ((len > 1) && (optionName[1] == 'c') &&
+ (strncmp(optionName, "-connecting", len) == 0)) {
+
+ Tcl_DStringAppend(dsPtr,
+ (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 ( (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 ( (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 (mask & TCL_READABLE) {
+ statePtr->watchEvents |= (FD_READ|FD_CLOSE);
+ }
+ if (mask & TCL_WRITABLE) {
+ statePtr->watchEvents |= (FD_WRITE|FD_CLOSE);
+ }
+
+ /*
+ * If there are any conditions already set, then tell the notifier to
+ * poll rather than block.
+ */
+
+ if (statePtr->readyEvents & statePtr->watchEvents) {
+ Tcl_Time blockTime = { 0, 0 };
+
+ 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;
+ /*
+ * We are started with async connect and the connect notification
+ * was not jet received
+ */
+ int async_connect = statePtr->flags & TCP_ASYNC_CONNECT;
+ /* We were called by the event procedure and continue our loop */
+ int async_callback = statePtr->flags & TCP_ASYNC_PENDING;
+ ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
+
+ if (async_callback) {
+ goto reenter;
+ }
+
+ for (statePtr->addr = statePtr->addrlist; statePtr->addr != NULL;
+ statePtr->addr = statePtr->addr->ai_next) {
+
+ for (statePtr->myaddr = statePtr->myaddrlist; statePtr->myaddr != NULL;
+ statePtr->myaddr = statePtr->myaddr->ai_next) {
+
+ /*
+ * No need to try combinations of local and remote addresses
+ * of different families.
+ */
+
+ if (statePtr->myaddr->ai_family != statePtr->addr->ai_family) {
+ continue;
+ }
+
+ /*
+ * Close the socket if it is still open from the last unsuccessful
+ * iteration.
+ */
+ if (statePtr->sockets->fd != INVALID_SOCKET) {
+ closesocket(statePtr->sockets->fd);
+ }
+
+ /* get statePtr lock */
+ WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
+
+ /*
+ * Reset last error from last try
+ */
+ statePtr->notifierConnectError = 0;
+ Tcl_SetErrno(0);
+
+ statePtr->sockets->fd = socket(statePtr->myaddr->ai_family, SOCK_STREAM, 0);
+
+ /* Free list lock */
+ SetEvent(tsdPtr->socketListLock);
+
+ /* continue on socket creation error */
+ if (statePtr->sockets->fd == INVALID_SOCKET) {
+ TclWinConvertError((DWORD) WSAGetLastError());
+ continue;
+ }
+
+ /*
+ * Win-NT has a misfeature that sockets are inherited in child
+ * processes by default. Turn off the inherit bit.
+ */
+
+ SetHandleInformation((HANDLE) statePtr->sockets->fd, HANDLE_FLAG_INHERIT, 0);
+
+ /*
+ * Set kernel space buffering
+ */
+
+ TclSockMinimumBuffers((void *) statePtr->sockets->fd, TCP_BUFFER_SIZE);
+
+ /*
+ * Try to bind to a local port.
+ */
+
+ if (bind(statePtr->sockets->fd, statePtr->myaddr->ai_addr,
+ statePtr->myaddr->ai_addrlen) == SOCKET_ERROR) {
+ TclWinConvertError((DWORD) WSAGetLastError());
+ continue;
+ }
+ /*
+ * For asyncroneous connect set the socket in nonblocking mode
+ * and activate connect notification
+ */
+ if (async_connect) {
+ TcpState *statePtr2;
+ int in_socket_list = 0;
+ /* get statePtr lock */
+ WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
+
+ /*
+ * Bugfig for 336441ed59 to not ignore notifications until the
+ * infoPtr is in the list.
+ * Check if my statePtr is already in the tsdPtr->socketList
+ * It is set after this call by TcpThreadActionProc and is set
+ * on a second round.
+ *
+ * If not, we buffer my statePtr in the tsd memory so it is not
+ * lost by the event procedure
+ */
+
+ for (statePtr2 = tsdPtr->socketList; statePtr2 != NULL;
+ statePtr2 = statePtr2->nextPtr) {
+ if (statePtr2 == statePtr) {
+ in_socket_list = 1;
+ break;
+ }
+ }
+ if (!in_socket_list) {
+ tsdPtr->pendingTcpState = statePtr;
+ }
+ /*
+ * Set connect mask to connect events
+ * This is activated by a SOCKET_SELECT message to the notifier
+ * thread.
+ */
+ statePtr->selectEvents |= FD_CONNECT;
+
+ /*
+ * Free list lock
+ */
+ SetEvent(tsdPtr->socketListLock);
+
+ /* activate accept notification */
+ SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT,
+ (LPARAM) statePtr);
+ }
+
+ /*
+ * Attempt to connect to the remote socket.
+ */
+
+ connect(statePtr->sockets->fd, statePtr->addr->ai_addr,
+ statePtr->addr->ai_addrlen);
+
+ error = WSAGetLastError();
+ TclWinConvertError(error);
+
+ if (async_connect && error == WSAEWOULDBLOCK) {
+ /*
+ * Asynchroneous connect
+ */
+
+ /*
+ * Remember that we jump back behind this next round
+ */
+ statePtr->flags |= TCP_ASYNC_PENDING;
+ return TCL_OK;
+
+ reenter:
+ /*
+ * Re-entry point for async connect after connect event or
+ * blocking operation
+ *
+ * Clear the reenter flag
+ */
+ statePtr->flags &= ~(TCP_ASYNC_PENDING);
+ /* get statePtr lock */
+ WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
+ /* Get signaled connect error */
+ TclWinConvertError((DWORD) statePtr->notifierConnectError);
+ /* Clear eventual connect flag */
+ statePtr->selectEvents &= ~(FD_CONNECT);
+ /* Free list lock */
+ SetEvent(tsdPtr->socketListLock);
+ }
+
+ /*
+ * Clear the tsd socket list pointer if we did not wait for
+ * the FD_CONNECT asyncroneously
+ */
+ tsdPtr->pendingTcpState = NULL;
+
+ if (Tcl_GetErrno() == 0) {
+ goto out;
+ }
+ }
+ }
+
+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.
+ */
+
+ SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT,
+ (LPARAM) statePtr);
+ } else {
+ /*
+ * Connect failed
+ */
+
+ /*
+ * For async connect schedule a writable event to report the fail.
+ */
+ if (async_callback) {
+ /*
+ * Set up the select mask for read/write events.
+ */
+ statePtr->selectEvents = FD_WRITE|FD_READ;
+ /* get statePtr lock */
+ WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
+ /* Signal ready readable and writable events */
+ statePtr->readyEvents |= FD_WRITE | FD_READ;
+ /* Flag error to event routine */
+ statePtr->flags |= TCP_ASYNC_FAILED;
+ /* Save connect error to be reported by 'fconfigure -error' */
+ statePtr->connectError = Tcl_GetErrno();
+ /* Free list lock */
+ SetEvent(tsdPtr->socketListLock);
+ }
+ /*
+ * Error message on 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) {
+ 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;
+ SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)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_OpenTcpServer --
+ *
+ * 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_OpenTcpServer(
+ Tcl_Interp *interp, /* For error reporting - may be NULL. */
+ int port, /* Port number to open. */
+ const char *myHost, /* Name of local host. */
+ Tcl_TcpAcceptProc *acceptProc,
+ /* Callback for accepting connections from new
+ * clients. */
+ ClientData acceptProcData) /* Data for the callback. */
+{
+ SOCKET sock = INVALID_SOCKET;
+ unsigned short chosenport = 0;
+ struct addrinfo *addrlist = NULL;
+ struct addrinfo *addrPtr; /* Socket address to listen on. */
+ TcpState *statePtr = NULL; /* The returned value. */
+ char channelName[SOCK_CHAN_LENGTH];
+ u_long flag = 1; /* Indicates nonblocking mode. */
+ const char *errorMsg = NULL;
+
+ 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 (!TclCreateSocketAddress(interp, &addrlist, myHost, port, 1, &errorMsg)) {
+ goto error;
+ }
+
+ for (addrPtr = addrlist; addrPtr != NULL; addrPtr = addrPtr->ai_next) {
+ sock = socket(addrPtr->ai_family, addrPtr->ai_socktype,
+ addrPtr->ai_protocol);
+ if (sock == INVALID_SOCKET) {
+ TclWinConvertError((DWORD) WSAGetLastError());
+ continue;
+ }
+
+ /*
+ * Win-NT has a misfeature that sockets are inherited in child
+ * processes by default. Turn off the inherit bit.
+ */
+
+ SetHandleInformation((HANDLE) sock, HANDLE_FLAG_INHERIT, 0);
+
+ /*
+ * Set kernel space buffering
+ */
+
+ TclSockMinimumBuffers((void *)sock, TCP_BUFFER_SIZE);
+
+ /*
+ * Make sure we use the same port when opening two server sockets
+ * for IPv4 and IPv6.
+ *
+ * As sockaddr_in6 uses the same offset and size for the port
+ * member as sockaddr_in, we can handle both through the IPv4 API.
+ */
+
+ if (port == 0 && chosenport != 0) {
+ ((struct sockaddr_in *) addrPtr->ai_addr)->sin_port =
+ htons(chosenport);
+ }
+
+ /*
+ * Bind to the specified port. Note that we must not call
+ * setsockopt with SO_REUSEADDR because Microsoft allows addresses
+ * to be reused even if they are still in use.
+ *
+ * Bind should not be affected by the socket having already been
+ * set into nonblocking mode. If there is trouble, this is one
+ * place to look for bugs.
+ */
+
+ if (bind(sock, addrPtr->ai_addr, addrPtr->ai_addrlen)
+ == SOCKET_ERROR) {
+ TclWinConvertError((DWORD) WSAGetLastError());
+ closesocket(sock);
+ continue;
+ }
+ if (port == 0 && chosenport == 0) {
+ address sockname;
+ socklen_t namelen = sizeof(sockname);
+
+ /*
+ * Synchronize port numbers when binding to port 0 of multiple
+ * addresses.
+ */
+
+ if (getsockname(sock, &sockname.sa, &namelen) >= 0) {
+ chosenport = ntohs(sockname.sa4.sin_port);
+ }
+ }
+
+ /*
+ * Set the maximum number of pending connect requests to the max
+ * value allowed on each platform (Win32 and Win32s may be
+ * different, and there may be differences between TCP/IP stacks).
+ */
+
+ if (listen(sock, SOMAXCONN) == SOCKET_ERROR) {
+ TclWinConvertError((DWORD) WSAGetLastError());
+ closesocket(sock);
+ continue;
+ }
+
+ if (statePtr == NULL) {
+ /*
+ * Add this socket to the global list of sockets.
+ */
+ statePtr = NewSocketInfo(sock);
+ } else {
+ AddSocketInfoFd( statePtr, sock );
+ }
+ }
+
+error:
+ if (addrlist != NULL) {
+ freeaddrinfo(addrlist);
+ }
+
+ if (statePtr != NULL) {
+ ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
+
+ statePtr->acceptProc = acceptProc;
+ statePtr->acceptProcData = acceptProcData;
+ sprintf(channelName, SOCK_TEMPLATE, statePtr);
+ statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
+ statePtr, 0);
+ /*
+ * Set up the select mask for connection request events.
+ */
+
+ 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);
+ SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT,
+ (LPARAM) 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);
+ SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT,
+ (LPARAM) 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 (!(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 (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 (!(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 ((statePtr->readyEvents &
+ (statePtr->watchEvents | FD_CONNECT | FD_ACCEPT))
+ && !(statePtr->flags & SOCKET_PENDING)
+ ) {
+ statePtr->flags |= SOCKET_PENDING;
+ evPtr = ckalloc(sizeof(SocketEvent));
+ evPtr->header.proc = SocketEventProc;
+ evPtr->socket = statePtr->sockets->fd;
+ Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
+ }
+ }
+ 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 (!(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
+ */
+
+ statePtr->flags &= ~SOCKET_PENDING;
+
+ /*
+ * Continue async connect if pending and ready
+ */
+
+ if ( statePtr->readyEvents & FD_CONNECT ) {
+ if ( statePtr->flags & TCP_ASYNC_PENDING ) {
+
+ /*
+ * Do one step and save eventual connect error
+ */
+
+ SetEvent(tsdPtr->socketListLock);
+ WaitForConnect(statePtr,NULL);
+
+ } else {
+
+ /*
+ * No async connect reenter pending. Just clear event.
+ */
+
+ statePtr->readyEvents &= ~(FD_CONNECT);
+ SetEvent(tsdPtr->socketListLock);
+ }
+ return 1;
+ }
+
+ /*
+ * Handle connection requests directly.
+ */
+ if (statePtr->readyEvents & FD_ACCEPT) {
+ for (fds = statePtr->sockets; fds != NULL; fds = fds->next) {
+
+ /*
+ * Accept the incoming connection request.
+ */
+ len = sizeof(address);
+
+ newSocket = accept(fds->fd, &(addr.sa), &len);
+
+ /* On Tcl server sockets with multiple OS fds we loop over the fds trying
+ * an accept() on each, so we expect INVALID_SOCKET. There are also other
+ * network stack conditions that can result in FD_ACCEPT but a subsequent
+ * failure on accept() by the time we get around to it.
+ * Access to sockets (acceptEventCount, readyEvents) in socketList
+ * is still protected by the lock (prevents reintroduction of
+ * SF Tcl Bug 3056775.
+ */
+
+ if (newSocket == INVALID_SOCKET) {
+ /* int err = WSAGetLastError(); */
+ continue;
+ }
+
+ /*
+ * It is possible that more than one FD_ACCEPT has been sent, so an extra
+ * count must be kept. Decrement the count, and reset the readyEvent bit
+ * if the count is no longer > 0.
+ */
+ statePtr->acceptEventCount--;
+
+ if (statePtr->acceptEventCount <= 0) {
+ statePtr->readyEvents &= ~(FD_ACCEPT);
+ }
+
+ 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;
+ statePtr->readyEvents &= ~(FD_ACCEPT);
+
+ SetEvent(tsdPtr->socketListLock);
+ return 1;
+ }
+
+ SetEvent(tsdPtr->socketListLock);
+
+ /*
+ * Mask off unwanted events and compute the read/write mask so we can
+ * notify the channel.
+ */
+
+ events = statePtr->readyEvents & statePtr->watchEvents;
+
+ if (events & FD_CLOSE) {
+ /*
+ * If the socket was closed and the channel is still interested in
+ * read events, then we need to ensure that we keep polling for this
+ * event until someone does something with the channel. Note that we
+ * do this before calling Tcl_NotifyChannel so we don't have to watch
+ * out for the channel being deleted out from under us. This may cause
+ * a redundant trip through the event loop, but it's simpler than
+ * trying to do unwind protection.
+ */
+
+ Tcl_Time blockTime = { 0, 0 };
+
+ Tcl_SetMaxBlockTime(&blockTime);
+ mask |= TCL_READABLE|TCL_WRITABLE;
+ } else if (events & FD_READ) {
+
+ /*
+ * Throw the readable event if an async connect failed.
+ */
+
+ if ( statePtr->flags & TCP_ASYNC_FAILED ) {
+
+ mask |= TCL_READABLE;
+
+ } else {
+ fd_set readFds;
+ struct timeval timeout;
+
+ /*
+ * We must check to see if data is really available, since someone
+ * could have consumed the data in the meantime. Turn off async
+ * notification so select will work correctly. If the socket is
+ * still readable, notify the channel driver, otherwise reset the
+ * async select handler and keep waiting.
+ */
+
+ SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
+ (WPARAM) UNSELECT, (LPARAM) statePtr);
+
+ FD_ZERO(&readFds);
+ FD_SET(statePtr->sockets->fd, &readFds);
+ timeout.tv_usec = 0;
+ timeout.tv_sec = 0;
+
+ if (select(0, &readFds, NULL, NULL, &timeout) != 0) {
+ mask |= TCL_READABLE;
+ } else {
+ statePtr->readyEvents &= ~(FD_READ);
+ SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
+ (WPARAM) SELECT, (LPARAM) statePtr);
+ }
+ }
+ }
+
+ /*
+ * writable event
+ */
+
+ if (events & FD_WRITE) {
+ 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.
+ */
+
+ SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT,
+ (LPARAM) statePtr);
+ SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT,
+ (LPARAM) statePtr);
+
+ while (1) {
+ int event_found;
+
+ /* get statePtr lock */
+ WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
+
+ /* Check if event occured */
+ event_found = (statePtr->readyEvents & events);
+
+ /* Free list lock */
+ SetEvent(tsdPtr->socketListLock);
+
+ /* exit loop if event occured */
+ if (event_found) {
+ break;
+ }
+
+ /* Exit loop if event did not occur but this is a non-blocking channel */
+ if (statePtr->flags & TCP_NONBLOCKING) {
+ *errorCodePtr = EWOULDBLOCK;
+ result = 0;
+ break;
+ }
+
+ /*
+ * Wait until something happens.
+ */
+
+ WaitForSingleObject(tsdPtr->readyEvent, INFINITE);
+ }
+
+ (void) Tcl_SetServiceMode(oldMode);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 (event & FD_CLOSE) {
+ statePtr->acceptEventCount = 0;
+ statePtr->readyEvents &= ~(FD_WRITE|FD_ACCEPT);
+ } else if (event & FD_ACCEPT) {
+ statePtr->acceptEventCount++;
+ }
+
+ if (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
+ */
+ 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.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#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);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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.
+ */
+
+ SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
+ (WPARAM) notifyCmd, (LPARAM) 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..f4e08fa
--- /dev/null
+++ b/win/tclWinTime.c
@@ -0,0 +1,1165 @@
+/*
+ * 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.
+ */
+
+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;
+
+/*
+ * 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.
+ */
+
+static struct tm * ComputeGMT(const time_t *tp);
+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;
+ int useFtime = 1; /* Flag == TRUE if we need to fall back on
+ * ftime rather than using the perf counter. */
+
+ /*
+ * 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 */
+ == 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.
+ */
+
+ 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;
+
+ EnterCriticalSection(&timeInfo.cs);
+
+ QueryPerformanceCounter(&curCounter);
+
+ /*
+ * 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 - timeInfo.perfCounterLastCall.QuadPart <
+ 11 * timeInfo.curCounterFreq.QuadPart / 10) {
+ curFileTime = timeInfo.fileTimeLastCall.QuadPart +
+ ((curCounter.QuadPart - timeInfo.perfCounterLastCall.QuadPart)
+ * 10000000 / timeInfo.curCounterFreq.QuadPart);
+ timeInfo.fileTimeLastCall.QuadPart = curFileTime;
+ timeInfo.perfCounterLastCall.QuadPart = curCounter.QuadPart;
+ usecSincePosixEpoch = (curFileTime - posixEpoch.QuadPart) / 10;
+ timePtr->sec = (long) (usecSincePosixEpoch / 1000000);
+ timePtr->usec = (unsigned long) (usecSincePosixEpoch % 1000000);
+ useFtime = 0;
+ }
+
+ LeaveCriticalSection(&timeInfo.cs);
+ }
+
+ if (useFtime) {
+ /*
+ * 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.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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..ee10b81
--- /dev/null
+++ b/win/tclooConfig.sh
@@ -0,0 +1,19 @@
+# tclooConfig.sh --
+#
+# This shell script (for sh) is generated automatically by TclOO's configure
+# script, or would be except it has no values that we substitute. It will
+# create shell variables for most of the configuration options discovered by
+# the configure script. This script is intended to be included by TEA-based
+# configure scripts for TclOO extensions so that they don't have to figure
+# this all out for themselves.
+#
+# The information in this file is specific to a single platform.
+
+# These are mostly empty because no special steps are ever needed from Tcl 8.6
+# onwards; all libraries and include files are just part of Tcl.
+TCLOO_LIB_SPEC=""
+TCLOO_STUB_LIB_SPEC=""
+TCLOO_INCLUDE_SPEC=""
+TCLOO_PRIVATE_INCLUDE_SPEC=""
+TCLOO_CFLAGS=""
+TCLOO_VERSION=1.0.4
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
new file mode 100644
index 0000000..e254318
--- /dev/null
+++ b/win/tclsh.ico
Binary files differ
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"