summaryrefslogtreecommitdiffstats
path: root/win
diff options
context:
space:
mode:
authorcvs2fossil <cvs2fossil>2000-08-08 19:03:31 (GMT)
committercvs2fossil <cvs2fossil>2000-08-08 19:03:31 (GMT)
commit45a4a0c600cf1445c9d027e479fbd935e036b8e1 (patch)
treebf3e807b918a716744437d65e496366d98e8df0c /win
parenta4d73ade8b0addef3a4e1244caa4dcfbf69d9241 (diff)
downloadtcl-tclpro_1_5_0_synthetic.zip
tcl-tclpro_1_5_0_synthetic.tar.gz
tcl-tclpro_1_5_0_synthetic.tar.bz2
Created branch tclpro-1-5-0-synthetictclpro_1_5_0tclpro_1_5_0_synthetic
Diffstat (limited to 'win')
-rw-r--r--win/Makefile.in557
-rw-r--r--win/README71
-rw-r--r--win/README.binary151
-rw-r--r--win/aclocal.m41
-rw-r--r--win/cat.c37
-rw-r--r--win/configure.in189
-rw-r--r--win/makefile.vc524
-rw-r--r--win/mkd.bat20
-rw-r--r--win/rmd.bat25
-rw-r--r--win/stub16.c198
-rw-r--r--win/tcl.hpj.in19
-rw-r--r--win/tcl.m4625
-rw-r--r--win/tcl.rc46
-rw-r--r--win/tclAppInit.c301
-rw-r--r--win/tclConfig.sh.in174
-rw-r--r--win/tclWin32Dll.c492
-rw-r--r--win/tclWinChan.c1100
-rw-r--r--win/tclWinConsole.c1278
-rw-r--r--win/tclWinDde.c1351
-rw-r--r--win/tclWinError.c392
-rw-r--r--win/tclWinFCmd.c1664
-rw-r--r--win/tclWinFile.c1034
-rw-r--r--win/tclWinInit.c845
-rw-r--r--win/tclWinInt.h109
-rw-r--r--win/tclWinLoad.c191
-rw-r--r--win/tclWinMtherr.c52
-rw-r--r--win/tclWinNotify.c514
-rw-r--r--win/tclWinPipe.c2825
-rw-r--r--win/tclWinPort.h454
-rw-r--r--win/tclWinReg.c1414
-rw-r--r--win/tclWinSerial.c1206
-rw-r--r--win/tclWinSock.c2456
-rw-r--r--win/tclWinTest.c190
-rw-r--r--win/tclWinThrd.c903
-rw-r--r--win/tclWinThrd.h21
-rw-r--r--win/tclWinTime.c442
-rw-r--r--win/tclsh.icobin3630 -> 0 bytes
-rw-r--r--win/tclsh.rc46
38 files changed, 0 insertions, 21917 deletions
diff --git a/win/Makefile.in b/win/Makefile.in
deleted file mode 100644
index c0cce6d..0000000
--- a/win/Makefile.in
+++ /dev/null
@@ -1,557 +0,0 @@
-#
-# 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.
-#
-# RCS: @(#) $Id: Makefile.in,v 1.33.2.3 2000/07/28 07:58:28 mo Exp $
-
-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@
-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)
-
-# 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 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
-
-# The default switches for optimization or debugging
-LDFLAGS_DEBUG = @LDFLAGS_DEBUG@
-LDFLAGS_OPTIMIZE = @LDFLAGS_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@
-
-# Special compiler flags to use when building man2tcl on Windows.
-MAN2TCLFLAGS = @MAN2TCLFLAGS@
-
-SRC_DIR = @srcdir@
-ROOT_DIR = @srcdir@/..
-GENERIC_DIR = @srcdir@/../generic
-WIN_DIR = @srcdir@
-COMPAT_DIR = @srcdir@/../compat
-
-# This is a switch passed to a Cygwin script that generates file
-# names based on the platform.
-PATHTYPE = @PATHTYPE@
-
-# This program converts between Windows native and Cygwin POSIX pathnames.
-CYGPATH = @CYGPATH@
-
-GENERIC_DIR_NATIVE = $(shell $(CYGPATH) $(PATHTYPE) '$(GENERIC_DIR)')
-WIN_DIR_NATIVE = $(shell $(CYGPATH) $(PATHTYPE) '$(WIN_DIR)')
-ROOT_DIR_NATIVE = $(shell $(CYGPATH) $(PATHTYPE) '$(ROOT_DIR)')
-
-LIBRARY_DIR = $(shell echo '$(ROOT_DIR_NATIVE)/library' | sed 's/\\/\//g' )
-
-DLLSUFFIX = @DLLSUFFIX@
-LIBSUFFIX = @LIBSUFFIX@
-EXESUFFIX = @EXESUFFIX@
-
-TCL_STUB_LIB_FILE = @TCL_STUB_LIB_FILE@
-TCL_DLL_FILE = @TCL_DLL_FILE@
-TCL_LIB_FILE = @TCL_LIB_FILE@
-DDE_DLL_FILE = tcldde$(VER)${DLLSUFFIX}
-DDE_LIB_FILE = tcldde$(VER)${LIBSUFFIX}
-REG_DLL_FILE = tclreg$(VER)${DLLSUFFIX}
-REG_LIB_FILE = tclreg$(VER)${LIBSUFFIX}
-PIPE_DLL_FILE = tclpip$(VER)${DLLSUFFIX}
-
-SHARED_LIBRARIES = $(TCL_DLL_FILE) $(TCL_STUB_LIB_FILE) \
- $(DDE_DLL_FILE) $(REG_DLL_FILE) $(PIPE_DLL_FILE)
-STATIC_LIBRARIES = $(TCL_LIB_FILE) $(REG_LIB_FILE) $(DDE_LIB_FILE)
-
-TCLSH = tclsh$(VER)${EXESUFFIX}
-TCLTEST = tcltest${EXEEXT}
-CAT32 = cat32$(EXEEXT)
-MAN2TCL = man2tcl$(EXEEXT)
-
-@SET_MAKE@
-
-# Macro that expands to the first dependency argument with the appropriate
-# path type already resolved.
-
-DEPARG = "$(shell $(CYGPATH) $(PATHTYPE) $<)"
-
-# Setting the VPATH variable to a list of paths will cause the
-# makefile to look into these paths when resolving .c to .obj
-# dependencies. Note the ':' to avoid autoconf's habit of deleting
-# all VPATH lines without an explicit ':' in it.
-
-VPATH = $(GENERIC_DIR)@VPSEP@$(WIN_DIR)@VPSEP@$(COMPAT_DIR) # :
-
-AR = @AR@
-RANLIB = @RANLIB@
-CC = @CC@
-RC = @RC@
-RES = @RES@
-AC_FLAGS = @EXTRA_CFLAGS@ @DEFS@
-CPPFLAGS = @CPPFLAGS@
-LDFLAGS = @LDFLAGS@
-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@ $(LIBS)
-SHLIB_CFLAGS = @SHLIB_CFLAGS@
-SHLIB_SUFFIX = @SHLIB_SUFFIX@
-VER = @TCL_MAJOR_VERSION@@TCL_MINOR_VERSION@
-DOTVER = @TCL_MAJOR_VERSION@.@TCL_MINOR_VERSION@
-LIBS = @LIBS@
-
-RMDIR = rm -rf
-MKDIR = mkdir -p
-SHELL = @SHELL@
-RM = rm -f
-COPY = cp
-
-CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${TCL_SHLIB_CFLAGS} \
--I"${GENERIC_DIR_NATIVE}" -I"${WIN_DIR_NATIVE}" ${AC_FLAGS} \
-${COMPILE_DEBUG_FLAGS}
-
-CC_OBJNAME = @CC_OBJNAME@
-CC_EXENAME = @CC_EXENAME@
-
-STUB_CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \
--I"${GENERIC_DIR_NATIVE}" -I"${WIN_DIR_NATIVE}" ${AC_FLAGS} \
-${COMPILE_DEBUG_FLAGS}
-
-TCLTEST_OBJS = \
- tclTest.$(OBJEXT) \
- tclTestObj.$(OBJEXT) \
- tclTestProcBodyObj.$(OBJEXT) \
- tclThreadTest.$(OBJEXT) \
- tclWinTest.$(OBJEXT) \
- testMain.$(OBJEXT)
-
-GENERIC_OBJS = \
- regcomp.$(OBJEXT) \
- regexec.$(OBJEXT) \
- regfree.$(OBJEXT) \
- regerror.$(OBJEXT) \
- tclAlloc.$(OBJEXT) \
- tclAsync.$(OBJEXT) \
- tclBasic.$(OBJEXT) \
- tclBinary.$(OBJEXT) \
- tclCkalloc.$(OBJEXT) \
- tclClock.$(OBJEXT) \
- tclCmdAH.$(OBJEXT) \
- tclCmdIL.$(OBJEXT) \
- tclCmdMZ.$(OBJEXT) \
- tclCompCmds.$(OBJEXT) \
- tclCompExpr.$(OBJEXT) \
- tclCompile.$(OBJEXT) \
- tclDate.$(OBJEXT) \
- tclEncoding.$(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) \
- tclIOSock.$(OBJEXT) \
- tclIOUtil.$(OBJEXT) \
- tclLink.$(OBJEXT) \
- tclLiteral.$(OBJEXT) \
- tclListObj.$(OBJEXT) \
- tclLoad.$(OBJEXT) \
- tclMain.$(OBJEXT) \
- tclNamesp.$(OBJEXT) \
- tclNotify.$(OBJEXT) \
- tclObj.$(OBJEXT) \
- tclPanic.$(OBJEXT) \
- tclParse.$(OBJEXT) \
- tclParseExpr.$(OBJEXT) \
- tclPipe.$(OBJEXT) \
- tclPkg.$(OBJEXT) \
- tclPosixStr.$(OBJEXT) \
- tclPreserve.$(OBJEXT) \
- tclProc.$(OBJEXT) \
- tclRegexp.$(OBJEXT) \
- tclResolve.$(OBJEXT) \
- tclResult.$(OBJEXT) \
- tclScan.$(OBJEXT) \
- tclStringObj.$(OBJEXT) \
- tclStubInit.$(OBJEXT) \
- tclStubLib.$(OBJEXT) \
- tclThread.$(OBJEXT) \
- tclTimer.$(OBJEXT) \
- tclUtf.$(OBJEXT) \
- tclUtil.$(OBJEXT) \
- tclVar.$(OBJEXT)
-
-WIN_OBJS = \
- tclWin32Dll.$(OBJEXT) \
- tclWinChan.$(OBJEXT) \
- tclWinConsole.$(OBJEXT) \
- tclWinSerial.$(OBJEXT) \
- tclWinError.$(OBJEXT) \
- tclWinFCmd.$(OBJEXT) \
- tclWinFile.$(OBJEXT) \
- tclWinInit.$(OBJEXT) \
- tclWinLoad.$(OBJEXT) \
- tclWinMtherr.$(OBJEXT) \
- tclWinNotify.$(OBJEXT) \
- tclWinPipe.$(OBJEXT) \
- tclWinSock.$(OBJEXT) \
- tclWinThrd.$(OBJEXT) \
- tclWinTime.$(OBJEXT)
-
-COMPAT_OBJS = \
- strftime.$(OBJEXT)
-
-PIPE_OBJS = stub16.$(OBJEXT)
-
-DDE_OBJS = tclWinDde.$(OBJEXT)
-
-REG_OBJS = tclWinReg.$(OBJEXT)
-
-STUB_OBJS = tclStubLib.$(OBJEXT)
-
-TCLSH_OBJS = tclAppInit.$(OBJEXT)
-
-TCL_OBJS = ${GENERIC_OBJS} ${WIN_OBJS} ${COMPAT_OBJS}
-
-TCL_DOCS = "$(ROOT_DIR_NATIVE)"/doc/*.[13n]
-
-all: binaries libraries doc
-
-tcltest: $(TCLTEST)
-
-binaries: @LIBRARIES@ $(TCLSH)
-
-libraries:
-
-doc:
-
-winhelp: $(ROOT_DIR)/tools/man2help.tcl $(MAN2TCL)
- TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \
- ./$(TCLSH) "$(ROOT_DIR_NATIVE)"/tools/man2help.tcl tcl "$(VER)" $(TCL_DOCS)
- hcw /c /e tcl.hpj
-
-$(MAN2TCL): $(ROOT_DIR)/tools/man2tcl.c
- $(CC) $(CFLAGS_OPTIMIZE) $(MAN2TCLFLAGS) -o $(MAN2TCL) "$(ROOT_DIR_NATIVE)"/tools/man2tcl.c
-
-$(TCLSH): $(TCL_LIB_FILE) $(TCLSH_OBJS) tclsh.$(RES)
- $(CC) $(CFLAGS) $(TCLSH_OBJS) $(TCL_LIB_FILE) $(LIBS) \
- tclsh.$(RES) $(CC_EXENAME)
-
-$(TCLTEST): $(TCL_LIB_FILE) $(TCLTEST_OBJS) $(CAT32) tclsh.$(RES)
- $(CC) $(CFLAGS) $(TCLTEST_OBJS) $(TCL_LIB_FILE) $(LIBS) \
- tclsh.$(RES) $(CC_EXENAME)
-
-cat32.$(OBJEXT): cat.c
- $(CC) -c $(CC_SWITCHES) $(DEPARG) $(CC_OBJNAME)
-
-$(CAT32): cat32.$(OBJEXT)
- $(CC) $(CFLAGS) cat32.$(OBJEXT) $(CC_EXENAME) $(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_LIB@ ${STUB_OBJS}
- @POST_MAKE_LIB@
-
-${TCL_DLL_FILE}: ${TCL_OBJS} tcl.$(RES)
- @$(RM) ${TCL_DLL_FILE}
- @MAKE_DLL@ ${TCL_OBJS} tcl.$(RES) $(SHLIB_LD_LIBS)
-
-${TCL_LIB_FILE}: ${TCL_OBJS}
- @$(RM) ${TCL_LIB_FILE}
- @MAKE_LIB@ ${TCL_OBJS}
- @POST_MAKE_LIB@
-
-${DDE_DLL_FILE}: ${DDE_OBJS} ${TCL_STUB_LIB_FILE}
- @$(RM) ${DDE_DLL_FILE}
- @MAKE_DLL@ ${DDE_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
-
-${DDE_LIB_FILE}: ${DDE_OBJS} ${TCL_LIB_FILE}
- @$(RM) ${DDE_LIB_FILE}
- @MAKE_LIB@ ${DDE_OBJS} ${TCL_LIB_FILE}
-
-${REG_DLL_FILE}: ${REG_OBJS} ${TCL_STUB_LIB_FILE}
- @$(RM) ${REG_DLL_FILE}
- @MAKE_DLL@ ${REG_OBJS} ${TCL_STUB_LIB_FILE} $(SHLIB_LD_LIBS)
-
-${REG_LIB_FILE}: ${REG_OBJS} ${TCL_LIB_FILE}
- @$(RM) ${REG_LIB_FILE}
- @MAKE_LIB@ ${REG_OBJS} ${TCL_LIB_FILE}
-
-# PIPE_DLL_FILE is actually an executable, don't build it
-# like a DLL.
-
-${PIPE_DLL_FILE}: ${PIPE_OBJS}
- @$(RM) ${PIPE_DLL_FILE}
- @MAKE_EXE@ $(CFLAGS) ${PIPE_OBJS} $(LIBS)
-
-# 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)
-
-testMain.${OBJEXT}: tclAppInit.c
- $(CC) -c $(CC_SWITCHES) -DTCL_TEST $(DEPARG) $(CC_OBJNAME)
-
-tclTest.${OBJEXT}: tclTest.c
- $(CC) -c $(CC_SWITCHES) $(DEPARG) $(CC_OBJNAME)
-
-tclTestObj.${OBJEXT}: tclTestObj.c
- $(CC) -c $(CC_SWITCHES) $(DEPARG) $(CC_OBJNAME)
-
-tclWinTest.${OBJEXT}: tclWinTest.c
- $(CC) -c $(CC_SWITCHES) $(DEPARG) $(CC_OBJNAME)
-
-tclAppInit.${OBJEXT} : tclAppInit.c
- $(CC) -c $(CC_SWITCHES) $(DEPARG) $(CC_OBJNAME)
-
-# The following objects should be built using the stub interfaces
-
-tclWinReg.${OBJEXT} : tclWinReg.c
- $(CC) -c $(CC_SWITCHES) -DUSE_TCL_STUBS $(DEPARG) $(CC_OBJNAME)
-
-tclWinDde.${OBJEXT} : tclWinDde.c
- $(CC) -c $(CC_SWITCHES) -DUSE_TCL_STUBS $(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)
-
-
-# Implicit rule for all object files that will end up in the Tcl library
-
-.c.${OBJEXT}:
- $(CC) -c $(CC_SWITCHES) -DBUILD_tcl ${DEPARG} $(CC_OBJNAME)
-
-.rc.$(RES):
- $(RC) @RC_OUT@ $@ @RC_TYPE@ @RC_INCLUDE@ "$(GENERIC_DIR_NATIVE)" @RC_INCLUDE@ "$(WIN_DIR_NATIVE)" $(DEPARG)
-
-install: all install-binaries install-libraries install-doc
-
-install-binaries:
- @$(MKDIR) -p "$(BIN_INSTALL_DIR)"
- @$(MKDIR) -p "$(LIB_INSTALL_DIR)"
- $(COPY) tclConfig.sh $(LIB_INSTALL_DIR)/tclConfig.sh
- @for i in dde1.1 reg1.0; \
- 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) $(TCLSH) $(PIPE_DLL_FILE); \
- do \
- if [ -f $$i ]; then \
- echo "Installing $$i"; \
- $(COPY) $$i "$(BIN_INSTALL_DIR)"; \
- fi; \
- done
- @for i in $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE); \
- do \
- if [ -f $$i ]; then \
- echo "Installing $$i"; \
- $(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)/dde1.1; \
- $(COPY) $(ROOT_DIR)/library/dde1.1/pkgIndex.tcl $(LIB_INSTALL_DIR)/dde1.1; \
- fi
- @if [ -f $(DDE_LIB_FILE) ]; then \
- echo installing $(DDE_LIB_FILE); \
- $(COPY) $(DDE_LIB_FILE) $(LIB_INSTALL_DIR)/dde1.1; \
- fi
- @if [ -f $(REG_DLL_FILE) ]; then \
- echo installing $(REG_DLL_FILE); \
- $(COPY) $(REG_DLL_FILE) $(LIB_INSTALL_DIR)/reg1.0; \
- $(COPY) $(ROOT_DIR)/library/reg1.0/pkgIndex.tcl $(LIB_INSTALL_DIR)/reg1.0; \
- fi
- @if [ -f $(REG_LIB_FILE) ]; then \
- echo installing $(REG_LIB_FILE); \
- $(COPY) $(REG_LIB_FILE) $(LIB_INSTALL_DIR)/reg1.0; \
- fi
-
-install-libraries:
- @for i in $(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 http2.3 opt0.4 encoding msgcat1.0 tcltest1.0; \
- 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" ; \
- 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;
- @for i in http2.3 http1.0 opt0.4 msgcat1.0 tcltest1.0; \
- do \
- echo "Installing library $$i directory"; \
- for j in $(ROOT_DIR)/library/$$i/*.tcl; \
- do \
- $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/$$i"; \
- done; \
- done;
- @echo "Installing encodings"
- @for i in $(ROOT_DIR)/library/encoding/*.enc ; do \
- $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)/encoding"; \
- done;
-
-install-doc:
-
-test: binaries $(TCLTEST)
- TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \
- ./$(TCLTEST) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \
- | ./$(CAT32)
-
-# Useful target to launch a built tcltest with the proper path,...
-runtest: tcltest
- @TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \
- ./tcltest
-
-depend:
-
-Makefile: $(SRC_DIR)/Makefile.in
- ./config.status
-
-cleanhelp:
- $(RM) *.hlp *.cnt *.GID *.rtf man2tcl.exe
-
-clean: cleanhelp
- $(RM) *.lib *.a *.exp *.dll *.$(RES) *.${OBJEXT} *~ \#* TAGS a.out
- $(RM) $(TCLSH) $(TCLTEST) $(CAT32)
- $(RM) *.pch *.ilk *.pdb
-
-distclean: clean
- $(RM) Makefile config.status config.cache config.log tclConfig.sh \
- tcl.hpj
-
-#
-# Regenerate the stubs files.
-#
-
-$(GENERIC_DIR)/tclStubInit.c: $(GENERIC_DIR)/tcl.decls \
- $(GENERIC_DIR)/tclInt.decls
- @TCL_LIBRARY="$(ROOT_DIR_NATIVE)/library"; export TCL_LIBRARY; \
- $(TCLSH) "$(ROOT_DIR_NATIVE)\tools\genStubs.tcl" \
- "$(GENERIC_DIR_NATIVE)" \
- "$(GENERIC_DIR_NATIVE)\tcl.decls" \
- "$(GENERIC_DIR_NATIVE)\tclInt.decls"
-
-genstubs:
- @TCL_LIBRARY="$(ROOT_DIR_NATIVE)/library"; export TCL_LIBRARY; \
- $(TCLSH) "$(ROOT_DIR_NATIVE)\tools\genStubs.tcl" \
- "$(GENERIC_DIR_NATIVE)" \
- "$(GENERIC_DIR_NATIVE)\tcl.decls" \
- "$(GENERIC_DIR_NATIVE)\tclInt.decls"
diff --git a/win/README b/win/README
deleted file mode 100644
index 3cda9e3..0000000
--- a/win/README
+++ /dev/null
@@ -1,71 +0,0 @@
-Tcl 8.3 for Windows
-
-by Scott Stanton
-Scriptics Corporation
-scott.stanton@scriptics.com
-
-RCS: @(#) $Id: README,v 1.16 2000/04/26 17:31:22 hobbs Exp $
-
-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://dev.scriptics.com/doc/howto/compile.html#win
-
-2. Compiling Tcl
-----------------
-
-In order to compile Tcl for Windows, you need the following items:
-
- Tcl 8.3 Source Distribution (plus any patches)
-
- Visual C++ 2.x/4.x/5.x
-
-In practice, this release is built with Visual C++ 5.0
-
-In the "win" subdirectory of the source release, you will find
-"makefile.vc". This is the makefile Visual C++ compiler. You should
-update the paths at the top of the file to reflect your system
-configuration. Now you can use "make" (or "nmake" for VC++) to build
-the tcl libraries and the tclsh executable.
-
-In order to use the binaries generated by these makefiles, you will
-need to place the Tcl script library files someplace where Tcl can
-find them. Tcl looks in one of following places for the library files:
-
- 1) The path specified in the environment variable "TCL_LIBRARY".
-
- 2) In the lib\tcl8.3 directory under the installation directory
- as specified in the registry:
-
- HKEY_LOCAL_MACHINE\SOFTWARE\Scriptics\Tcl\8.3
-
- 3) Relative to the directory containing the current .exe.
- Tcl will look for a directory "..\lib\tcl8.3" relative to the
- directory containing the currently running .exe.
-
-Note that in order to run tclsh83.exe, you must ensure that tcl83.dll
-and tclpip83.dll are on your path, in the system directory, or in the
-directory containing tclsh83.exe.
-
-Note: Tcl no longer provides support for Win32s.
-
-This page includes a lengthy discussion of compiler macros necessary
-when compiling Tcl extensions that will be dynamically loaded.
-
-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. Please use the online database at
- http://dev.scriptics.com/ticket/
-
-In order to run the test suite, you build the "test" target using the
-appropriate makefile for your compiler.
-
diff --git a/win/README.binary b/win/README.binary
deleted file mode 100644
index 7bdeca8..0000000
--- a/win/README.binary
+++ /dev/null
@@ -1,151 +0,0 @@
-Tcl/Tk 8.3 for Windows, Binary Distribution
-
-RCS: @(#) $Id: README.binary,v 1.19.2.1 2000/07/27 01:39:23 hobbs Exp $
-
-1. Introduction
----------------
-
-This directory contains the binary distribution of Tcl/Tk 8.3.2 for
-Windows. It was compiled with Microsoft Visual C++ 5.0 using Win32
-API, so that it will run under Windows NT, 95, 98 and 2000.
-
-Tcl provides a powerful platform for creating integration applications
-that tie together diverse applications, protocols, devices, and
-frameworks. When paired with the Tk toolkit, Tcl provides the fastest
-and most powerful way to create GUI applications that run on PCs, Unix,
-and the Macintosh. Tcl can also be used for a variety of web-related
-tasks and for creating powerful command languages for applications.
-
-Tcl is maintained, enhanced, and distributed freely as a service to the
-Tcl community by Scriptics Corporation.
-
-2. Documentation
-----------------
-
-The official home for Tcl and Tk on the Web is at:
- http://dev.scriptics.com
-
-The home page for the Tcl/Tk 8.3 release is
- http://dev.scriptics.com/software/tcltk/8.3.html
-
-Detailed release notes can be found at
- http://dev.scriptics.com/software/tcltk/relnotes/tcl8.3.2.txt
-
-Information about Tcl itself can be found at
- http://dev.scriptics.com/scripting/
-
-There are many Tcl books on the market. Most are listed at
- http://dev.scriptics.com/resource/doc/books/
-
-There are notes about compiling Tcl at
- http://dev.scriptics.com/doc/howto/compile.html
-
-3. Installation
----------------
-
-The binary release is distributed as a self-extracting archive called
-tcl83.exe. The setup program which will prompt you for an
-installation directory. It will create the installation heirarchy
-under the specified directory, and install a wish application icon
-under the program manager group of your choice.
-
-We are no longer supporting use of Tcl with 16-bit versions of
-Windows. Microsoft has completely dropped support of the Win32s
-subsystem.
-
-4. Linking against the binary release
---------------------------------------
-
-In order to link your applications against the .dll files shipped with
-this release, you will need to use the appropriate .lib file for your
-compiler. In the lib directory of the installation directory, there
-are library files for the Microsoft Visual C++ compiler:
-
- tcl83.lib
- tk83.lib
-
-5. Building dynamically loadable extensions
---------------------------------------------
-
-Please refer to the example dynamically loadable extension provided on
-our ftp site:
-
- ftp://ftp.scriptics.com/pub/tcl/misc/example.zip
-
-This archive contains a template that you can use for building
-extensions that will be loadable on Unix, Windows, and Macintosh
-systems.
-
-6. Reporting Bugs
------------------
-If you have comments or bug reports for the Windows version of Tcl,
-please use our online database at:
-
- http://dev.scriptics.com/ticket/
-
-or post them to the newsgroup comp.lang.tcl.
-
-7. Tcl newsgroup
------------------
-
-There is a network news group "comp.lang.tcl" intended for the exchange
-of information about Tcl, Tk, and related applications. Feel free to use
-the newsgroup both for general information questions and for bug reports.
-We read the newsgroup and will attempt to fix bugs and problems reported
-to it.
-
-When using comp.lang.tcl, please be sure that your e-mail return address
-is correctly set in your postings. This allows people to respond directly
-to you, rather than the entire newsgroup, for answers that are not of
-general interest. A bad e-mail return address may prevent you from
-getting answers to your questions. You may have to reconfigure your news
-reading software to ensure that it is supplying valid e-mail addresses.
-
-8. Tcl contributed archive
---------------------------
-
-Many people have created exciting packages and applications based on Tcl
-and/or Tk and made them freely available to the Tcl community. An archive
-of these contributions is kept on the machine ftp.neosoft.com. You
-can access the archive using anonymous FTP; the Tcl contributed archive is
-in the directory "/pub/tcl". The archive also contains several FAQ
-("frequently asked questions") documents that provide solutions to problems
-that are commonly encountered by TCL newcomers.
-
-9. Tcl Resource Center
-----------------------
-Visit http://dev.scritics.com/resource/ to see an annotated index of
-many Tcl resources available on the World Wide Web. This includes
-papers, books, and FAQs, as well as extensions, applications, binary
-releases, and patches. You can contribute patches by sending them
-to <patches@scriptics.com>. You can also recommend more URLs for the
-resource center using the forms labeled "Add a Resource".
-
-10. Mailing lists
-----------------
-
-A couple of mailing lists have been set up to discuss Macintosh or
-Windows related Tcl issues. In order to use these Mailing Lists you
-must have access to the internet. To subscribe send a message to:
-
- wintcl-request@scriptics.com
- mactcl-request@scriptics.com
-
-In the body of the message (the subject will be ignored) put:
-
- subscribe mactcl Joe Blow
-
-Replacing Joe Blow with your real name, of course. (Use wintcl
-instead of mactcl if you're interested in the Windows list.) If you
-would just like to receive more information about the list without
-subscribing put the line:
-
- information mactcl
-
-in the body instead (or wintcl). There are also Special Interest
-Groups (SIGs) setup for these topics and more at:
-
- http://dev.scriptics.com/
-
-
-
diff --git a/win/aclocal.m4 b/win/aclocal.m4
deleted file mode 100644
index bc7540d..0000000
--- a/win/aclocal.m4
+++ /dev/null
@@ -1 +0,0 @@
-builtin(include,tcl.m4)
diff --git a/win/cat.c b/win/cat.c
deleted file mode 100644
index cdd83a5..0000000
--- a/win/cat.c
+++ /dev/null
@@ -1,37 +0,0 @@
-/*
- * 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.
- *
- * RCS: @(#) $Id: cat.c,v 1.2 1998/09/14 18:40:19 stanton Exp $
- */
-
-#include <stdio.h>
-#include <io.h>
-#include <string.h>
-
-int
-main()
-{
- char buf[1024];
- int n;
- 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/configure.in b/win/configure.in
deleted file mode 100644
index 0e3a421..0000000
--- a/win/configure.in
+++ /dev/null
@@ -1,189 +0,0 @@
-# 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.
-#
-# RCS: @(#) $Id: configure.in,v 1.20.2.2 2000/07/28 07:58:28 mo Exp $
-
-AC_INIT(../generic/tcl.h)
-
-TCL_VERSION=8.3
-TCL_MAJOR_VERSION=8
-TCL_MINOR_VERSION=3
-TCL_PATCH_LEVEL=".2"
-VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION
-
-if test "${prefix}" = "NONE"; then
- prefix=/usr/local
-fi
-if test "${exec_prefix}" = "NONE"; then
- exec_prefix=$prefix
-fi
-
-#--------------------------------------------------------------------
-# Check whether --enable-gcc or --disable-gcc was given. Do this
-# before AC_PROG_CC and AC_CYGWIN are called so the compiler can
-# be fully tested by built-in autoconf tools.
-#--------------------------------------------------------------------
-
-SC_ENABLE_GCC
-
-#--------------------------------------------------------------------
-# Checks to see if the make progeam sets the $MAKE variable.
-#--------------------------------------------------------------------
-
-AC_PROG_MAKE_SET
-
-#--------------------------------------------------------------------
-# These two macros perform additinal compiler test.
-#--------------------------------------------------------------------
-
-AC_CYGWIN
-
-#--------------------------------------------------------------------
-# 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
-
-#--------------------------------------------------------------------
-# 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
-
-#--------------------------------------------------------------------
-# 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
-
-CFLAGS=${CFLAGS_DEFAULT}
-LDFLAGS=${LDFLAGS_DEFAULT}
-TCL_DBGX=${DBGX}
-
-#--------------------------------------------------------------------
-# man2tcl needs this so that it can use errno.h
-#--------------------------------------------------------------------
-
-AC_CHECK_HEADER(errno.h, , MAN2TCLFLAGS="-DNO_ERRNO_H")
-AC_SUBST(MAN2TCLFLAGS)
-
-#------------------------------------------------------------------------
-# 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/..; pwd`\""
-
-eval "TCL_DLL_FILE=tcl${VER}${DLLSUFFIX}"
-
-eval "TCL_LIB_FILE=${LIBPREFIX}tcl$VER${LIBSUFFIX}"
-# FIMXE: These variables decls are missing
-#TCL_LIB_FLAG
-#TCL_BUILD_LIB_SPEC
-#TCL_LIB_SPEC
-
-eval "TCL_STUB_LIB_FILE=\"${LIBPREFIX}tclstub${VER}${LIBSUFFIX}\""
-eval "TCL_STUB_LIB_FLAG=\"-ltclstub${VER}${TCL_DBGX}\""
-eval "TCL_BUILD_STUB_LIB_SPEC=\"-L`pwd` ${TCL_STUB_LIB_FLAG}\""
-eval "TCL_STUB_LIB_SPEC=\"-L${exec_prefix}/lib ${TCL_STUB_LIB_FLAG}\""
-eval "TCL_BUILD_STUB_LIB_PATH=\"`pwd`/${TCL_STUB_LIB_FILE}\""
-eval "TCL_STUB_LIB_PATH=\"${exec_prefix}/lib/${TCL_STUB_LIB_FILE}\""
-
-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}
-
-AC_SUBST(TCL_VERSION)
-AC_SUBST(TCL_MAJOR_VERSION)
-AC_SUBST(TCL_MINOR_VERSION)
-AC_SUBST(TCL_PATCH_LEVEL)
-AC_SUBST(TCL_LIB_FILE)
-AC_SUBST(TCL_LIB_FLAG)
-AC_SUBST(TCL_DLL_FILE)
-AC_SUBST(TCL_STUB_LIB_FILE)
-AC_SUBST(TCL_STUB_LIB_FLAG)
-AC_SUBST(TCL_BUILD_STUB_LIB_SPEC)
-AC_SUBST(TCL_STUB_LIB_SPEC)
-AC_SUBST(TCL_BUILD_STUB_LIB_PATH)
-AC_SUBST(TCL_STUB_LIB_PATH)
-
-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)
-AC_SUBST(TCL_SHARED_BUILD)
-
-AC_SUBST(PATHTYPE)
-AC_SUBST(CYGPATH)
-AC_SUBST(VPSEP)
-AC_SUBST(CFLAGS_DEBUG)
-AC_SUBST(CFLAGS_OPTIMIZE)
-AC_SUBST(CFLAGS_WARNING)
-AC_SUBST(EXTRA_CFLAGS)
-AC_SUBST(STLIB_LD)
-AC_SUBST(SHLIB_LD)
-AC_SUBST(SHLIB_LD_LIBS)
-AC_SUBST(SHLIB_CFLAGS)
-AC_SUBST(SHLIB_SUFFIX)
-AC_SUBST(CC_OBJNAME)
-AC_SUBST(CC_EXENAME)
-AC_SUBST(LDFLAGS)
-AC_SUBST(LDFLAGS_DEBUG)
-AC_SUBST(LDFLAGS_OPTIMIZE)
-AC_SUBST(LDFLAGS_CONSOLE)
-AC_SUBST(LDFLAGS_WINDOW)
-AC_SUBST(AR)
-AC_SUBST(RANLIB)
-AC_SUBST(RC)
-AC_SUBST(RC_OUT)
-AC_SUBST(RC_TYPE)
-AC_SUBST(RC_INCLUDE)
-AC_SUBST(RES)
-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(POST_MAKE_LIB)
-AC_SUBST(MAKE_DLL)
-AC_SUBST(MAKE_EXE)
-
-AC_OUTPUT(Makefile tclConfig.sh tcl.hpj)
diff --git a/win/makefile.vc b/win/makefile.vc
deleted file mode 100644
index 72ce802..0000000
--- a/win/makefile.vc
+++ /dev/null
@@ -1,524 +0,0 @@
-# Visual C++ 2.x and 4.0 makefile
-#
-# 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.
-#
-# RCS: @(#) $Id: makefile.vc,v 1.50.2.1 2000/07/27 01:39:24 hobbs Exp $
-
-# 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 VC++ 32-bit development tools. Note that the
-# VC++ 2.0 header files are broken, so you need to use the
-# ones that come with the developer network CD's, or later
-# versions of VC++.
-#
-# INSTALLDIR = where the install- targets should copy the binaries and
-# support files
-#
-
-# Set this to the appropriate value of /MACHINE: for your platform
-MACHINE = IX86
-
-ROOT = ..
-INSTALLDIR = c:\Progra~1\Tcl
-
-!IF "$(MACHINE)" == "IA64"
-TOOLS32 = c:\ia64sdk17
-TOOLS32_rc = c:\ia64sdk17
-!ELSE
-TOOLS32 = c:\Progra~1\devstudio\vc
-TOOLS32_rc = c:\Progra~1\devstudio\sharedide
-!ENDIF
-
-# Uncomment the following line to compile with thread support
-#THREADDEFINES = -DTCL_THREADS=1
-
-# Set NODEBUG to 0 to compile with symbols
-NODEBUG = 1
-
-# 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.3
-VERSION = 83
-
-BINROOT = .
-!IF "$(NODEBUG)" == "1"
-TMPDIRNAME = Release
-DBGX =
-!ELSE
-TMPDIRNAME = Debug
-DBGX = d
-!ENDIF
-TMPDIR = $(BINROOT)\$(TMPDIRNAME)
-OUTDIRNAME = $(TMPDIRNAME)
-OUTDIR = $(TMPDIR)
-
-TCLLIB = $(OUTDIR)\$(NAMEPREFIX)$(VERSION)$(DBGX).lib
-TCLDLLNAME = $(NAMEPREFIX)$(VERSION)$(DBGX).dll
-TCLDLL = $(OUTDIR)\$(TCLDLLNAME)
-
-TCLSTUBLIBNAME = $(STUBPREFIX)$(VERSION)$(DBGX).lib
-TCLSTUBLIB = $(OUTDIR)\$(TCLSTUBLIBNAME)
-
-TCLPLUGINLIB = $(OUTDIR)\$(NAMEPREFIX)$(VERSION)p$(DBGX).lib
-TCLPLUGINDLLNAME= $(NAMEPREFIX)$(VERSION)p$(DBGX).dll
-TCLPLUGINDLL = $(OUTDIR)\$(TCLPLUGINDLLNAME)
-TCLSH = $(OUTDIR)\$(NAMEPREFIX)sh$(VERSION)$(DBGX).exe
-TCLSHP = $(OUTDIR)\$(NAMEPREFIX)shp$(VERSION)$(DBGX).exe
-TCLPIPEDLLNAME = $(NAMEPREFIX)pip$(VERSION)$(DBGX).dll
-TCLPIPEDLL = $(OUTDIR)\$(TCLPIPEDLLNAME)
-TCLREGDLLNAME = $(NAMEPREFIX)reg$(VERSION)$(DBGX).dll
-TCLREGDLL = $(OUTDIR)\$(TCLREGDLLNAME)
-TCLDDEDLLNAME = $(NAMEPREFIX)dde$(VERSION)$(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)\strftime.obj \
- $(TMPDIR)\tclAlloc.obj \
- $(TMPDIR)\tclAsync.obj \
- $(TMPDIR)\tclBasic.obj \
- $(TMPDIR)\tclBinary.obj \
- $(TMPDIR)\tclCkalloc.obj \
- $(TMPDIR)\tclClock.obj \
- $(TMPDIR)\tclCmdAH.obj \
- $(TMPDIR)\tclCmdIL.obj \
- $(TMPDIR)\tclCmdMZ.obj \
- $(TMPDIR)\tclCompCmds.obj \
- $(TMPDIR)\tclCompExpr.obj \
- $(TMPDIR)\tclCompile.obj \
- $(TMPDIR)\tclDate.obj \
- $(TMPDIR)\tclEncoding.obj \
- $(TMPDIR)\tclEnv.obj \
- $(TMPDIR)\tclEvent.obj \
- $(TMPDIR)\tclExecute.obj \
- $(TMPDIR)\tclFCmd.obj \
- $(TMPDIR)\tclFileName.obj \
- $(TMPDIR)\tclGet.obj \
- $(TMPDIR)\tclHash.obj \
- $(TMPDIR)\tclHistory.obj \
- $(TMPDIR)\tclIndexObj.obj \
- $(TMPDIR)\tclInterp.obj \
- $(TMPDIR)\tclIO.obj \
- $(TMPDIR)\tclIOCmd.obj \
- $(TMPDIR)\tclIOGT.obj \
- $(TMPDIR)\tclIOSock.obj \
- $(TMPDIR)\tclIOUtil.obj \
- $(TMPDIR)\tclLink.obj \
- $(TMPDIR)\tclLiteral.obj \
- $(TMPDIR)\tclListObj.obj \
- $(TMPDIR)\tclLoad.obj \
- $(TMPDIR)\tclMain.obj \
- $(TMPDIR)\tclNamesp.obj \
- $(TMPDIR)\tclNotify.obj \
- $(TMPDIR)\tclObj.obj \
- $(TMPDIR)\tclPanic.obj \
- $(TMPDIR)\tclParse.obj \
- $(TMPDIR)\tclParseExpr.obj \
- $(TMPDIR)\tclPipe.obj \
- $(TMPDIR)\tclPkg.obj \
- $(TMPDIR)\tclPosixStr.obj \
- $(TMPDIR)\tclPreserve.obj \
- $(TMPDIR)\tclProc.obj \
- $(TMPDIR)\tclRegexp.obj \
- $(TMPDIR)\tclResolve.obj \
- $(TMPDIR)\tclResult.obj \
- $(TMPDIR)\tclScan.obj \
- $(TMPDIR)\tclStringObj.obj \
- $(TMPDIR)\tclStubInit.obj \
- $(TMPDIR)\tclStubLib.obj \
- $(TMPDIR)\tclThread.obj \
- $(TMPDIR)\tclTimer.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)\tclWinMtherr.obj \
- $(TMPDIR)\tclWinNotify.obj \
- $(TMPDIR)\tclWinPipe.obj \
- $(TMPDIR)\tclWinSock.obj \
- $(TMPDIR)\tclWinThrd.obj \
- $(TMPDIR)\tclWinTime.obj
-
-TCLSTUBOBJS = $(TMPDIR)\tclStubLib.obj \
-
-cc32 = "$(TOOLS32)\bin\cl.exe"
-link32 = "$(TOOLS32)\bin\link.exe"
-rc32 = "$(TOOLS32_rc)\bin\rc.exe"
-include32 = -I"$(TOOLS32)\include"
-libpath32 = /LIBPATH:"$(TOOLS32)\lib"
-lib32 = "$(TOOLS32)\bin\lib.exe"
-
-WINDIR = $(ROOT)\win
-GENERICDIR = $(ROOT)\generic
-
-TCL_INCLUDES = -I"$(WINDIR)" -I"$(GENERICDIR)"
-TCL_DEFINES = $(DEBUGDEFINES) $(THREADDEFINES)
-
-######################################################################
-# Compile flags
-######################################################################
-
-!IF "$(NODEBUG)" == "1"
-# This cranks the optimization level to maximize speed
-cdebug = -O2 -Gs -GD
-!ELSE
-!IF "$(MACHINE)" == "IA64"
-cdebug = -Od -Zi
-!ELSE
-cdebug = -Z7 -Od -WX
-!ENDIF
-!ENDIF
-
-# declarations common to all compiler options
-cflags = -c -W3 -nologo -Fp$(TMPDIR)\ -YX
-cvarsdll = -MD$(DBGX)
-
-TCL_CFLAGS = $(cdebug) $(cflags) $(cvarsdll) $(include32) \
- $(TCL_INCLUDES) $(TCL_DEFINES)
-CON_CFLAGS = $(cdebug) $(cflags) $(include32) -DCONSOLE
-
-######################################################################
-# Link flags
-######################################################################
-
-!IF "$(NODEBUG)" == "1"
-ldebug = /RELEASE
-!ELSE
-ldebug = -debug:full -debugtype:cv
-!ENDIF
-
-# declarations common to all linker options
-lflags = /NODEFAULTLIB /NOLOGO /MACHINE:$(MACHINE) $(libpath32)
-
-# declarations for use on Intel i386, i486, and Pentium systems
-!IF "$(MACHINE)" == "IX86"
-DLLENTRY = @12
-dlllflags = $(lflags) -entry:_DllMainCRTStartup$(DLLENTRY) -dll
-!ELSE
-!IF "$(MACHINE)" == "IA64"
-DLLENTRY = @12
-dlllflags = $(lflags) -dll
-!ELSE
-dlllflags = $(lflags) -entry:_DllMainCRTStartup$(DLLENTRY) -dll
-!ENDIF
-!ENDIF
-
-conlflags = $(lflags) -subsystem:console -entry:mainCRTStartup
-guilflags = $(lflags) -subsystem:windows -entry:WinMainCRTStartup
-
-!IF "$(MACHINE)" == "PPC"
-libc = libc$(DBGX).lib
-libcdll = crtdll$(DBGX).lib
-!ELSE
-libc = libc$(DBGX).lib oldnames.lib
-libcdll = msvcrt$(DBGX).lib oldnames.lib
-!ENDIF
-
-baselibs = kernel32.lib $(optlibs) advapi32.lib user32.lib
-winlibs = $(baselibs) gdi32.lib comdlg32.lib winspool.lib
-
-guilibs = $(libc) $(winlibs)
-conlibs = $(libc) $(baselibs)
-guilibsdll = $(libcdll) $(winlibs)
-conlibsdll = $(libcdll) $(baselibs)
-
-######################################################################
-# Project specific targets
-######################################################################
-
-release: setup $(TCLSH) dlls
-dlls: setup $(TCLPIPEDLL) $(TCLREGDLL) $(TCLDDEDLL)
-all: setup $(TCLSH) dlls $(CAT32)
-tcltest: setup $(TCLTEST) dlls $(CAT32)
-plugin: setup $(TCLPLUGINDLL) $(TCLSHP)
-install: install-binaries install-libraries
-test: setup $(TCLTEST) dlls $(CAT32)
- set TCL_LIBRARY=$(ROOT)/library
- $(TCLTEST) $(ROOT)/tests/all.tcl
-
-setup:
- @$(MKDIR) $(TMPDIR)
- @$(MKDIR) $(OUTDIR)
-
-$(TCLLIB): $(TCLDLL)
-
-$(TCLDLL): $(TCLOBJS) $(TMPDIR)\tcl.res
- $(link32) $(ldebug) $(dlllflags) \
- -out:$@ $(TMPDIR)\tcl.res $(guilibsdll) @<<
-$(TCLOBJS)
-<<
-
-$(TCLSTUBLIB): $(TCLSTUBOBJS)
- $(lib32) /out:$@ $(TCLSTUBOBJS)
-
-$(TCLPLUGINLIB): $(TCLPLUGINDLL)
-
-$(TCLPLUGINDLL): $(TCLOBJS) $(TMPDIR)\tcl.res
- $(link32) $(ldebug) $(dlllflags) \
- -out:$@ $(TMPDIR)\tcl.res $(guilibsdll) @<<
-$(TCLOBJS)
-<<
-
-$(TCLSH): $(TCLSHOBJS) $(TCLLIB) $(TMPDIR)\tclsh.res
- $(link32) $(ldebug) $(conlflags) $(TMPDIR)\tclsh.res -stack:2300000 \
- -out:$@ $(conlibsdll) $(TCLLIB) $(TCLSHOBJS)
-
-$(TCLSHP): $(TCLSHOBJS) $(TCLPLUGINLIB) $(TMPDIR)\tclsh.res
- $(link32) $(ldebug) $(conlflags) $(TMPDIR)\tclsh.res -stack:2300000 \
- -out:$@ $(conlibsdll) $(TCLPLUGINLIB) $(TCLSHOBJS)
-
-$(TCLTEST): $(TCLTESTOBJS) $(TCLLIB) $(TMPDIR)\tclsh.res
- $(link32) $(ldebug) $(conlflags) $(TMPDIR)\tclsh.res -stack:2300000 \
- -out:$@ $(conlibsdll) $(TCLLIB) $(TCLTESTOBJS)
-
-$(TCLPIPEDLL): $(WINDIR)\stub16.c
- $(cc32) $(CON_CFLAGS) -Fo$(TMPDIR)\ $(WINDIR)\stub16.c
- $(link32) $(ldebug) $(conlflags) -out:$@ $(TMPDIR)\stub16.obj $(guilibs)
-
-$(TCLDDEDLL): $(TMPDIR)\tclWinDde.obj $(TCLSTUBLIB)
- $(link32) $(ldebug) $(dlllflags) -out:$@ $(TMPDIR)\tclWinDde.obj \
- $(conlibsdll) $(TCLSTUBLIB)
-
-$(TCLREGDLL): $(TMPDIR)\tclWinReg.obj $(TCLSTUBLIB)
- $(link32) $(ldebug) $(dlllflags) -out:$@ $(TMPDIR)\tclWinReg.obj \
- $(conlibsdll) $(TCLSTUBLIB)
-
-$(CAT32): $(WINDIR)\cat.c
- $(cc32) $(CON_CFLAGS) -Fo$(TMPDIR)\ $?
- $(link32) $(conlflags) -out:$@ -stack:16384 $(TMPDIR)\cat.obj $(conlibs)
-
-install-binaries: $(TCLSH)
- $(MKDIR) "$(BIN_INSTALL_DIR)"
- $(MKDIR) "$(LIB_INSTALL_DIR)"
- @echo installing $(TCLDLLNAME)
- @copy "$(TCLDLL)" "$(BIN_INSTALL_DIR)"
- @copy "$(TCLLIB)" "$(LIB_INSTALL_DIR)"
- @echo installing "$(TCLSH)"
- @copy "$(TCLSH)" "$(BIN_INSTALL_DIR)"
- @echo installing $(TCLPIPEDLLNAME)
- @copy "$(TCLPIPEDLL)" "$(BIN_INSTALL_DIR)"
- @echo installing $(TCLSTUBLIBNAME)
- @copy "$(TCLSTUBLIB)" "$(LIB_INSTALL_DIR)"
-
-install-libraries:
- -@$(MKDIR) "$(LIB_INSTALL_DIR)"
- -@$(MKDIR) "$(INCLUDE_INSTALL_DIR)"
- -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)"
- @echo installing http1.0
- -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http1.0"
- -@copy "$(ROOT)\library\http1.0\http.tcl" "$(SCRIPT_INSTALL_DIR)\http1.0"
- -@copy "$(ROOT)\library\http1.0\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http1.0"
- @echo installing http2.3
- -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http2.3"
- -@copy "$(ROOT)\library\http2.3\http.tcl" "$(SCRIPT_INSTALL_DIR)\http2.3"
- -@copy "$(ROOT)\library\http2.3\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http2.3"
- @echo installing opt0.4
- -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\opt0.4"
- -@copy "$(ROOT)\library\opt0.4\optparse.tcl" "$(SCRIPT_INSTALL_DIR)\opt0.4"
- -@copy "$(ROOT)\library\opt0.4\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\opt0.4"
- @echo installing msgcat1.0
- -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\msgcat1.0"
- -@copy "$(ROOT)\library\msgcat1.0\msgcat.tcl" "$(SCRIPT_INSTALL_DIR)\msgcat1.0"
- -@copy "$(ROOT)\library\msgcat1.0\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\msgcat1.0"
- @echo installing $(TCLDDEDLLNAME)
- -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\dde1.1"
- -@copy "$(TCLDDEDLL)" "$(SCRIPT_INSTALL_DIR)\dde1.1"
- -@copy "$(ROOT)\library\dde1.1\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\dde1.1"
- @echo installing $(TCLREGDLLNAME)
- -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\reg1.0"
- -@copy "$(TCLREGDLL)" "$(SCRIPT_INSTALL_DIR)\reg1.0"
- -@copy "$(ROOT)\library\reg1.0\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\reg1.0"
- @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 "$(ROOT)\library\history.tcl" "$(SCRIPT_INSTALL_DIR)"
- -@copy "$(ROOT)\library\init.tcl" "$(SCRIPT_INSTALL_DIR)"
- -@copy "$(ROOT)\library\ldAout.tcl" "$(SCRIPT_INSTALL_DIR)"
- -@copy "$(ROOT)\library\parray.tcl" "$(SCRIPT_INSTALL_DIR)"
- -@copy "$(ROOT)\library\safe.tcl" "$(SCRIPT_INSTALL_DIR)"
- -@copy "$(ROOT)\library\tclIndex" "$(SCRIPT_INSTALL_DIR)"
- -@copy "$(ROOT)\library\package.tcl" "$(SCRIPT_INSTALL_DIR)"
- -@copy "$(ROOT)\library\word.tcl" "$(SCRIPT_INSTALL_DIR)"
- -@copy "$(ROOT)\library\auto.tcl" "$(SCRIPT_INSTALL_DIR)"
-
-#
-# Regenerate the stubs files.
-#
-
-genstubs:
- tclsh$(VERSION) $(ROOT)\tools\genStubs.tcl $(GENERICDIR) \
- $(GENERICDIR)\tcl.decls $(GENERICDIR)\tclInt.decls
-
-#
-# Regenerate the windows help files.
-#
-
-TCLTOOLS = $(ROOT)/tools
-MAN2TCL = $(TCLTOOLS)/man2tcl
-TCLRTF = $(TCLTOOLS)/tcl.rtf
-TCLHPJ = $(TCLTOOLS)/tcl.hpj
-MAN2HELP = $(TCLTOOLS)/man2help.tcl
-HCRTF = $(TOOLS32)/bin/hcrtf.exe
-
-winhelp: $(TCLRTF)
- cd $(TCLTOOLS)
- start /wait $(HCRTF) -xn $(TCLHPJ)
-
-$(MAN2TCL).exe: $(MAN2TCL).obj
- cd $(TCLTOOLS)
- $(cc32) /nologo /G4 /ML /O2 $(MAN2TCL).c
-
-$(TCLRTF): $(MAN2TCL).exe $(TCLSH)
- cd $(TCLTOOLS)
- ..\win\$(TCLSH) $(MAN2HELP) $(NAMEPREFIX) $(VERSION) $(ROOT)/doc ../../tk$(DOTVERSION)/doc
-
-#
-# Special case object file targets
-#
-
-$(TMPDIR)\tclWinInit.obj: $(WINDIR)\tclWinInit.c
- $(cc32) -DBUILD_tcl $(TCL_CFLAGS) $(EXTFLAGS) -Fo$(TMPDIR)\ $?
-
-$(TMPDIR)\testMain.obj: $(WINDIR)\tclAppInit.c
- $(cc32) $(TCL_CFLAGS) -DTCL_TEST -Fo$(TMPDIR)\testMain.obj $?
-
-$(TMPDIR)\tclTest.obj: $(GENERICDIR)\tclTest.c
- $(cc32) $(TCL_CFLAGS) -Fo$@ $?
-
-$(TMPDIR)\tclTestObj.obj: $(GENERICDIR)\tclTestObj.c
- $(cc32) $(TCL_CFLAGS) -Fo$@ $?
-
-$(TMPDIR)\tclWinTest.obj: $(WINDIR)\tclWinTest.c
- $(cc32) $(TCL_CFLAGS) -Fo$@ $?
-
-$(TMPDIR)\tclAppInit.obj : $(WINDIR)\tclAppInit.c
- $(cc32) $(TCL_CFLAGS) -Fo$@ $?
-
-# The following objects should be built using the stub interfaces
-
-$(TMPDIR)\tclWinReg.obj : $(WINDIR)\tclWinReg.c
- $(cc32) $(TCL_CFLAGS) -DUSE_TCL_STUBS -Fo$@ $?
-
-$(TMPDIR)\tclWinDde.obj : $(WINDIR)\tclWinDde.c
- $(cc32) $(TCL_CFLAGS) -DUSE_TCL_STUBS -Fo$@ $?
-
-# 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 -Fo$@ $?
-
-
-# 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) -Fo$(TMPDIR)\ $<
-
-{$(GENERICDIR)}.c{$(TMPDIR)}.obj:
- $(cc32) -DBUILD_tcl $(TCL_CFLAGS) -Fo$(TMPDIR)\ $<
-
-{$(ROOT)\compat}.c{$(TMPDIR)}.obj:
- $(cc32) -DBUILD_tcl $(TCL_CFLAGS) -Fo$(TMPDIR)\ $<
-
-{$(WINDIR)}.rc{$(TMPDIR)}.res:
- $(rc32) -fo $@ -r -i $(GENERICDIR) -i $(WINDIR) -D__WIN32__ \
- $(TCL_DEFINES) $<
-
-clean:
- -@$(RM) $(OUTDIR)\*.exp
- -@$(RM) $(OUTDIR)\*.lib
- -@$(RM) $(OUTDIR)\*.dll
- -@$(RM) $(OUTDIR)\*.exe
- -@$(RM) $(OUTDIR)\*.pdb
- -@$(RM) $(TMPDIR)\*.pch
- -@$(RM) $(TMPDIR)\*.obj
- -@$(RM) $(TMPDIR)\*.res
- -@$(RM) $(TMPDIR)\*.exe
- -@$(RMDIR) $(OUTDIR)
- -@$(RMDIR) $(TMPDIR)
diff --git a/win/mkd.bat b/win/mkd.bat
deleted file mode 100644
index 97f36ae..0000000
--- a/win/mkd.bat
+++ /dev/null
@@ -1,20 +0,0 @@
-@echo off
-rem RCS: @(#) $Id: mkd.bat,v 1.5 1999/12/22 00:00:16 hobbs Exp $
-
-if exist %1\. goto end
-
-if "%OS%" == "Windows_NT" goto winnt
-
-md %1
-if errorlevel 1 goto end
-
-goto success
-
-:winnt
-md %1
-if errorlevel 1 goto end
-
-:success
-echo created directory %1
-
-:end
diff --git a/win/rmd.bat b/win/rmd.bat
deleted file mode 100644
index 7b5ce5f..0000000
--- a/win/rmd.bat
+++ /dev/null
@@ -1,25 +0,0 @@
-@echo off
-rem RCS: @(#) $Id: rmd.bat,v 1.5 1999/12/22 00:00:16 hobbs Exp $
-
-if not exist %1\. goto end
-
-echo Removing directory %1
-
-if "%OS%" == "Windows_NT" goto winnt
-
-cd %1
-if errorlevel 1 goto end
-del *.*
-cd ..
-rmdir %1
-if errorlevel 1 goto end
-goto success
-
-:winnt
-rmdir %1 /s /q
-if errorlevel 1 goto end
-
-:success
-echo deleted directory %1
-
-:end
diff --git a/win/stub16.c b/win/stub16.c
deleted file mode 100644
index 7114d4e..0000000
--- a/win/stub16.c
+++ /dev/null
@@ -1,198 +0,0 @@
-/*
- * stub16.c
- *
- * A helper program used for running 16-bit DOS applications under
- * Windows 95.
- *
- * Copyright (c) 1996 by Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * RCS: @(#) $Id: stub16.c,v 1.4 1999/04/21 21:50:34 rjohnson Exp $
- */
-
-#define STRICT
-
-#include <windows.h>
-#include <stdio.h>
-
-static HANDLE CreateTempFile(void);
-
-/*
- *---------------------------------------------------------------------------
- *
- * main
- *
- * Entry point for the 32-bit console mode app used by Windows 95 to
- * help run the 16-bit program specified on the command line.
- *
- * 1. EOF on a pipe that connects a detached 16-bit process and a
- * 32-bit process is never seen. So, this process runs the 16-bit
- * process _attached_, and then it is run detached from the calling
- * 32-bit process.
- *
- * 2. If a 16-bit process blocks reading from or writing to a pipe,
- * it never wakes up, and eventually brings the whole system down
- * with it if you try to kill the process. This app simulates
- * pipes. If any of the stdio handles is a pipe, this program
- * accumulates information into temp files and forwards it to or
- * from the DOS application as appropriate. This means that this
- * program must receive EOF from a stdin pipe before it will actually
- * start the DOS app, and the DOS app must finish generating stdout
- * or stderr before the data will be sent to the next stage of the
- * pipe. If the stdio handles are not pipes, no accumulation occurs
- * and the data is passed straight through to and from the DOS
- * application.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The child process is created and this process waits for it to
- * complete.
- *
- *---------------------------------------------------------------------------
- */
-
-int
-main()
-{
- DWORD dwRead, dwWrite;
- char *cmdLine;
- HANDLE hStdInput, hStdOutput, hStdError;
- HANDLE hFileInput, hFileOutput, hFileError;
- STARTUPINFO si;
- PROCESS_INFORMATION pi;
- char buf[8192];
- DWORD result;
-
- hFileInput = INVALID_HANDLE_VALUE;
- hFileOutput = INVALID_HANDLE_VALUE;
- hFileError = INVALID_HANDLE_VALUE;
- result = 1;
-
- /*
- * Don't get command line from argc, argv, because the command line
- * tokenizer will have stripped off all the escape sequences needed
- * for quotes and backslashes, and then we'd have to put them all
- * back in again. Get the raw command line and parse off what we
- * want ourselves. The command line should be of the form:
- *
- * stub16.exe program arg1 arg2 ...
- */
-
- cmdLine = strchr(GetCommandLine(), ' ');
- if (cmdLine == NULL) {
- return 1;
- }
- cmdLine++;
-
- hStdInput = GetStdHandle(STD_INPUT_HANDLE);
- hStdOutput = GetStdHandle(STD_OUTPUT_HANDLE);
- hStdError = GetStdHandle(STD_ERROR_HANDLE);
-
- if (GetFileType(hStdInput) == FILE_TYPE_PIPE) {
- hFileInput = CreateTempFile();
- if (hFileInput == INVALID_HANDLE_VALUE) {
- goto cleanup;
- }
- while (ReadFile(hStdInput, buf, sizeof(buf), &dwRead, NULL) != FALSE) {
- if (dwRead == 0) {
- break;
- }
- if (WriteFile(hFileInput, buf, dwRead, &dwWrite, NULL) == FALSE) {
- goto cleanup;
- }
- }
- SetFilePointer(hFileInput, 0, 0, FILE_BEGIN);
- SetStdHandle(STD_INPUT_HANDLE, hFileInput);
- }
- if (GetFileType(hStdOutput) == FILE_TYPE_PIPE) {
- hFileOutput = CreateTempFile();
- if (hFileOutput == INVALID_HANDLE_VALUE) {
- goto cleanup;
- }
- SetStdHandle(STD_OUTPUT_HANDLE, hFileOutput);
- }
- if (GetFileType(hStdError) == FILE_TYPE_PIPE) {
- hFileError = CreateTempFile();
- if (hFileError == INVALID_HANDLE_VALUE) {
- goto cleanup;
- }
- SetStdHandle(STD_ERROR_HANDLE, hFileError);
- }
-
- ZeroMemory(&si, sizeof(si));
- si.cb = sizeof(si);
- if (CreateProcess(NULL, cmdLine, NULL, NULL, TRUE, 0, NULL, NULL, &si,
- &pi) == FALSE) {
- goto cleanup;
- }
-
- WaitForInputIdle(pi.hProcess, 5000);
- WaitForSingleObject(pi.hProcess, INFINITE);
- GetExitCodeProcess(pi.hProcess, &result);
- CloseHandle(pi.hProcess);
- CloseHandle(pi.hThread);
-
- if (hFileOutput != INVALID_HANDLE_VALUE) {
- SetFilePointer(hFileOutput, 0, 0, FILE_BEGIN);
- while (ReadFile(hFileOutput, buf, sizeof(buf), &dwRead, NULL) != FALSE) {
- if (dwRead == 0) {
- break;
- }
- if (WriteFile(hStdOutput, buf, dwRead, &dwWrite, NULL) == FALSE) {
- break;
- }
- }
- }
- if (hFileError != INVALID_HANDLE_VALUE) {
- SetFilePointer(hFileError, 0, 0, FILE_BEGIN);
- while (ReadFile(hFileError, buf, sizeof(buf), &dwRead, NULL) != FALSE) {
- if (dwRead == 0) {
- break;
- }
- if (WriteFile(hStdError, buf, dwRead, &dwWrite, NULL) == FALSE) {
- break;
- }
- }
- }
-
-cleanup:
- if (hFileInput != INVALID_HANDLE_VALUE) {
- CloseHandle(hFileInput);
- }
- if (hFileOutput != INVALID_HANDLE_VALUE) {
- CloseHandle(hFileOutput);
- }
- if (hFileError != INVALID_HANDLE_VALUE) {
- CloseHandle(hFileError);
- }
- CloseHandle(hStdInput);
- CloseHandle(hStdOutput);
- CloseHandle(hStdError);
- ExitProcess(result);
- return 1;
-}
-
-static HANDLE
-CreateTempFile()
-{
- char name[MAX_PATH];
- SECURITY_ATTRIBUTES sa;
-
- if (GetTempPath(sizeof(name), name) == 0) {
- return INVALID_HANDLE_VALUE;
- }
- if (GetTempFileName(name, "tcl", 0, name) == 0) {
- return INVALID_HANDLE_VALUE;
- }
-
- sa.nLength = sizeof(sa);
- sa.lpSecurityDescriptor = NULL;
- sa.bInheritHandle = TRUE;
- return CreateFile(name, GENERIC_READ | GENERIC_WRITE, 0, &sa,
- CREATE_ALWAYS, FILE_ATTRIBUTE_TEMPORARY | FILE_FLAG_DELETE_ON_CLOSE,
- NULL);
-}
diff --git a/win/tcl.hpj.in b/win/tcl.hpj.in
deleted file mode 100644
index c1a805a..0000000
--- a/win/tcl.hpj.in
+++ /dev/null
@@ -1,19 +0,0 @@
-; 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=tcl83.cnt
-COPYRIGHT=Copyright © 2000 Scriptics Corporation
-HLP=tcl83.hlp
-
-[FILES]
-tcl.rtf
-
-[WINDOWS]
-main="Tcl/Tk Reference Manual",,0
-
-[CONFIG]
-BrowseButtons()
diff --git a/win/tcl.m4 b/win/tcl.m4
deleted file mode 100644
index 86fd936..0000000
--- a/win/tcl.m4
+++ /dev/null
@@ -1,625 +0,0 @@
-#------------------------------------------------------------------------
-# SC_PATH_TCLCONFIG --
-#
-# Locate the tclConfig.sh file and perform a sanity check on
-# the Tcl compile flags
-# Currently a no-op for Windows
-#
-# Arguments:
-# PATCH_LEVEL The patch level for Tcl if any.
-#
-# Results:
-#
-# Adds the following arguments to configure:
-# --with-tcl=...
-#
-# Sets the following vars:
-# TCL_BIN_DIR Full path to the tclConfig.sh file
-#------------------------------------------------------------------------
-
-AC_DEFUN(SC_PATH_TCLCONFIG, [
- AC_MSG_CHECKING([the location of tclConfig.sh])
-
- if test -d ../../tcl8.3$1/win; then
- TCL_BIN_DIR_DEFAULT=../../tcl8.3$1/win
- else
- TCL_BIN_DIR_DEFAULT=../../tcl8.3/win
- fi
-
- AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl 8.3 binaries from DIR],
- TCL_BIN_DIR=$withval, TCL_BIN_DIR=`cd $TCL_BIN_DIR_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/tclConfig.sh; then
- AC_MSG_ERROR(There is no tclConfig.sh in $TCL_BIN_DIR: perhaps you did not specify the Tcl *build* directory (not the toplevel Tcl directory) or you forgot to configure Tcl?)
- fi
- AC_MSG_RESULT($TCL_BIN_DIR/tclConfig.sh)
-])
-
-#------------------------------------------------------------------------
-# SC_PATH_TKCONFIG --
-#
-# Locate the tkConfig.sh file
-# Currently a no-op for Windows
-#
-# Arguments:
-# none
-#
-# Results:
-#
-# Adds the following arguments to configure:
-# --with-tk=...
-#
-# Sets the following vars:
-# TK_BIN_DIR Full path to the tkConfig.sh file
-#------------------------------------------------------------------------
-
-AC_DEFUN(SC_PATH_TKCONFIG, [
- AC_MSG_CHECKING([the location of tkConfig.sh])
-
- if test -d ../../tk8.3$1/win; then
- TK_BIN_DIR_DEFAULT=../../tk8.3$1/win
- else
- TK_BIN_DIR_DEFAULT=../../tk8.3/win
- fi
-
- AC_ARG_WITH(tk, [ --with-tk=DIR use Tk 8.3 binaries from DIR],
- TK_BIN_DIR=$withval, TK_BIN_DIR=`cd $TK_BIN_DIR_DEFAULT; pwd`)
- if test ! -d $TK_BIN_DIR; then
- AC_MSG_ERROR(Tk directory $TK_BIN_DIR does not exist)
- fi
- if test ! -f $TK_BIN_DIR/tkConfig.sh; then
- AC_MSG_ERROR(There is no tkConfig.sh in $TK_BIN_DIR: perhaps you did not specify the Tk *build* directory (not the toplevel Tk directory) or you forgot to configure Tk?)
- fi
-
- AC_MSG_RESULT([$TK_BIN_DIR/tkConfig.sh])
-])
-
-#------------------------------------------------------------------------
-# SC_LOAD_TCLCONFIG --
-#
-# Load the tclConfig.sh file
-# Currently a no-op for Windows
-#
-# Arguments:
-#
-# Requires the following vars to be set:
-# TCL_BIN_DIR
-#
-# Results:
-#
-# Subst 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([file not found])
- fi
-
- # The eval is required to do the TCL_DBGX substitution in the
- # TCL_LIB_FILE variable.
-
- eval TCL_LIB_FILE=${TCL_LIB_FILE}
- eval TCL_LIB_FLAG=${TCL_LIB_FLAG}
-
- AC_SUBST(TCL_BIN_DIR)
- AC_SUBST(TCL_SRC_DIR)
- AC_SUBST(TCL_LIB_FILE)
-])
-
-#------------------------------------------------------------------------
-# SC_LOAD_TKCONFIG --
-#
-# Load the tkConfig.sh file
-# Currently a no-op for Windows
-#
-# 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 $TCLCONFIG])
-
- if test -f "$TK_BIN_DIR/tkConfig.sh" ; then
- AC_MSG_CHECKING([loading $TK_BIN_DIR/tkConfig.sh])
- . $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_GCC --
-#
-# Allows the use of GCC if available
-#
-# Arguments:
-# none
-#
-# Results:
-#
-# Adds the following arguments to configure:
-# --enable-gcc
-#
-# Sets the following vars:
-# CC Command to use for the compiler
-# AR Comman for the archive tool
-# RANLIB Command for the archive indexing tool
-# RC Command for the resource compiler
-#
-#------------------------------------------------------------------------
-
-AC_DEFUN(SC_ENABLE_GCC, [
- AC_ARG_ENABLE(gcc, [ --enable-gcc allow use of gcc if available [--disable-gcc]],
- [ok=$enableval], [ok=no])
- if test "$ok" = "yes"; then
- # Quick hack to simulate a real cross check
- # The right way to do this is to use AC_CHECK_TOOL
- # correctly, but this is the minimal change
- # we need until the real fix is ready.
- if test "$host" != "$build" ; then
- if test -z "$CC"; then
- CC=${host}-gcc
- fi
- AC_PROG_CC
- AC_CHECK_PROG(AR, ${host}-ar, ${host}-ar)
- AC_CHECK_PROG(RANLIB, ${host}-ranlib, ${host}-ranlib)
- AC_CHECK_PROG(RC, ${host}-windres, ${host}-windres)
- else
- if test -z "$CC"; then
- CC=gcc
- fi
- AC_PROG_CC
- AC_CHECK_PROG(AR, ar, ar)
- AC_CHECK_PROG(RANLIB, ranlib, ranlib)
- AC_CHECK_PROG(RC, windres, windres)
- fi
- else
- # Allow user to override
- if test -z "$CC"; then
- CC=cl
- fi
- fi
-])
-
-#------------------------------------------------------------------------
-# 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 [--enable-shared]],
- [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)
- 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],
- [tcl_ok=$enableval], [tcl_ok=no])
-
- if test "$tcl_ok" = "yes"; then
- AC_MSG_RESULT(yes)
- TCL_THREADS=1
- AC_DEFINE(TCL_THREADS)
- else
- TCL_THREADS=0
- AC_MSG_RESULT([no (default)])
- fi
-])
-
-#------------------------------------------------------------------------
-# SC_ENABLE_SYMBOLS --
-#
-# Specify if debugging symbols should be used
-#
-# Arguments:
-# none
-#
-# Requires the following vars to be set:
-# 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 [--disable-symbols]], [tcl_ok=$enableval], [tcl_ok=no])
-
- if test "$tcl_ok" = "yes"; then
- CFLAGS_DEFAULT="${CFLAGS_DEBUG}"
- LDFLAGS_DEFAULT="${LDFLAGS_DEBUG}"
- DBGX=d
- AC_MSG_RESULT([yes])
- else
- CFLAGS_DEFAULT="${CFLAGS_OPTIMIZE}"
- LDFLAGS_DEFAULT="${LDFLAGS_OPTIMIZE}"
- DBGX=""
- AC_MSG_RESULT([no])
- 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
-# PATHTYPE
-# VPSEP
-# CYGPATH
-# SHLIB_LD
-# SHLIB_LD_LIBS
-# LIBS
-# AR
-# RC
-# RES
-#
-# MAKE_LIB
-# MAKE_EXE
-# MAKE_DLL
-#
-# LIBSUFFIX
-# LIBPREFIX
-# LIBRARIES
-# EXESUFFIX
-# DLLSUFFIX
-#
-#--------------------------------------------------------------------
-
-AC_DEFUN(SC_CONFIG_CFLAGS, [
- AC_MSG_CHECKING([compiler flags])
-
- # Set some defaults (may get changed below)
- EXTRA_CFLAGS=""
- PATHTYPE='-w'
- CYGPATH='cygpath'
- VPSEP=';'
-
- # set various compiler flags depending on whether we are using gcc or cl
-
- if test "${GCC}" = "yes" ; then
- SHLIB_LD=""
- SHLIB_LD_LIBS=""
- LIBS=""
- LIBS_GUI="-lgdi32 -lcomdlg32"
- STLIB_LD="${AR}"
- RC_OUT=-o
- RC_TYPE=
- RC_INCLUDE=--include
- RES=res.o
- MAKE_LIB="\${AR} crv \[$]@"
- POST_MAKE_LIB="\${RANLIB} \[$]@"
- MAKE_EXE="\${CC} -o \[$]@"
- LIBPREFIX="lib"
-
- if "$CC" -v 2>&1 | egrep '\/gcc-lib\/i[[3-6]]86[[^\/]]*-cygwin' >/dev/null; then
- mno_cygwin="yes"
- extra_cflags="-mno-cygwin"
- extra_ldflags="-mno-cygwin"
- else
- mno_cygwin="no"
- extra_cflags=""
- extra_ldflags=""
- fi
-
- if test "$cross_compiling" = "yes" -o "$mno_cygwin" = "yes"; then
- PATHTYPE=''
- CYGPATH='echo '
- VPSEP=':'
- fi
-
- if test "${SHARED_BUILD}" = "0" ; then
- # static
- AC_MSG_RESULT([using static flags])
- runtime=
- MAKE_DLL="echo "
- LIBSUFFIX="s\${DBGX}.a"
- LIBRARIES="\${STATIC_LIBRARIES}"
- EXESUFFIX="s\${DBGX}.exe"
- DLLSUFFIX=""
- else
- # dynamic
- AC_MSG_RESULT([using shared flags])
-
- # check to see if ld supports --shared. Libtool does a much
- # more extensive test, but not really needed in this case.
- if test -z "$LD"; then
- ld_prog="`(${CC} -print-prog-name=ld) 2>/dev/null`"
- if test -z "$ld_prog"; then
- ld_prog=ld
- else
- # get rid of the potential '\r' from ld_prog.
- ld_prog="`(echo $ld_prog | tr -d '\015' | sed 's,\\\\,\\/,g')`"
- fi
- LD="$ld_prog"
- fi
-
- AC_MSG_CHECKING([whether $ld_prog supports -shared option])
-
- # now the ad-hoc check to see if GNU ld supports --shared.
- if "$LD" --shared 2>&1 | egrep ': -shared not supported' >/dev/null; then
- ld_supports_shared="no"
- SHLIB_LD="${DLLWRAP-dllwrap}"
- else
- ld_supports_shared="yes"
- SHLIB_LD="${CC} -shared"
- fi
- AC_MSG_RESULT([$ld_supports_shared])
-
- runtime=
- # Add SHLIB_LD_LIBS to the Make rule, not here.
- MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -o \[$]@ ${extra_ldflags}"
- if test "${ld_supports_shared}" = "yes"; then
- MAKE_DLL="${MAKE_DLL} -Wl,--out-implib,\$(patsubst %.dll,lib%.a,\[$]@)"
- else
- MAKE_DLL="${MAKE_DLL} --output-lib \$(patsubst %.dll,lib%.a,\[$]@)"
- fi
- LIBSUFFIX="\${DBGX}.a"
- DLLSUFFIX="\${DBGX}.dll"
- EXESUFFIX="\${DBGX}.exe"
- LIBRARIES="\${SHARED_LIBRARIES}"
- fi
-
- EXTRA_CFLAGS="${extra_cflags}"
-
- CFLAGS_DEBUG=-g
- CFLAGS_OPTIMIZE=-O
- CFLAGS_WARNING="-Wall -Wconversion"
- LDFLAGS_DEBUG=-g
- LDFLAGS_OPTIMIZE=-O
-
- # 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.
- LDFLAGS_CONSOLE="-mconsole ${extra_ldflags}"
- LDFLAGS_WINDOW="-mwindows ${extra_ldflags}"
- else
- SHLIB_LD="link -dll -nologo"
- SHLIB_LD_LIBS="user32.lib advapi32.lib"
- LIBS="user32.lib advapi32.lib"
- LIBS_GUI="gdi32.lib comdlg32.lib"
- AR="lib -nologo"
- STLIB_LD="lib -nologo"
- RC="rc"
- RC_OUT=-fo
- RC_TYPE=-r
- RC_INCLUDE=-i
- RES=res
- MAKE_LIB="\${AR} -out:\[$]@"
- POST_MAKE_LIB=
- MAKE_EXE="\${CC} -Fe\[$]@"
- LIBPREFIX=""
-
- if test "${SHARED_BUILD}" = "0" ; then
- # static
- AC_MSG_RESULT([using static flags])
- runtime=-MT
- MAKE_DLL="echo "
- LIBSUFFIX="s\${DBGX}.lib"
- LIBRARIES="\${STATIC_LIBRARIES}"
- EXESUFFIX="s\${DBGX}.exe"
- DLLSUFFIX=""
- else
- # dynamic
- AC_MSG_RESULT([using shared flags])
- runtime=-MD
- # Add SHLIB_LD_LIBS to the Make rule, not here.
- MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -out:\[$]@"
- LIBSUFFIX="\${DBGX}.lib"
- DLLSUFFIX="\${DBGX}.dll"
- EXESUFFIX="\${DBGX}.exe"
- LIBRARIES="\${SHARED_LIBRARIES}"
- fi
-
- EXTRA_CFLAGS="-YX"
- CFLAGS_DEBUG="-nologo -Z7 -Od -WX ${runtime}d"
-# CFLAGS_OPTIMIZE="-nologo -O2 -Gs -GD ${runtime}"
- CFLAGS_OPTIMIZE="-nologo -Oti -Gs -GD ${runtime}"
- CFLAGS_WARNING="-W3"
- LDFLAGS_DEBUG="-debug:full -debugtype:cv"
- LDFLAGS_OPTIMIZE="-release"
-
- # Specify the CC output file names based on the target name
- CC_OBJNAME="-Fo\[$]@"
- CC_EXENAME="-Fe\"\$(shell \$(CYGPATH) \$(PATHTYPE) '\[$]@')\""
-
- # Specify linker flags depending on the type of app being
- # built -- Console vs. Window.
- LDFLAGS_CONSOLE="-link -subsystem:console"
- LDFLAGS_WINDOW="-link -subsystem:windows"
- fi
-])
-
-#------------------------------------------------------------------------
-# 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.3$1/win; then
- TCL_BIN_DEFAULT=../../tcl8.3$1/win
- else
- TCL_BIN_DEFAULT=../../tcl8.3/win
- fi
-
- AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl 8.3 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)
-])
-
-# FIXME : SC_PROG_TCLSH should really look for the installed tclsh and
-# not the build version. If we want to use the build version in the
-# tk script, it is better to hardcode that!
-
-#------------------------------------------------------------------------
-# SC_PROG_TCLSH
-# Locate a tclsh shell in the following directories:
-# ${exec_prefix}/bin
-# ${prefix}/bin
-# ${TCL_BIN_DIR}
-# ${TCL_BIN_DIR}/../bin
-# ${PATH}
-#
-# 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 ${exec_prefix}/bin:${prefix}/bin:${TCL_BIN_DIR}:${TCL_BIN_DIR}/../bin:${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
- AC_MSG_ERROR(No tclsh found in PATH: $search_path)
- fi
- AC_SUBST(TCLSH_PROG)
-])
diff --git a/win/tcl.rc b/win/tcl.rc
deleted file mode 100644
index 5b9a8cf..0000000
--- a/win/tcl.rc
+++ /dev/null
@@ -1,46 +0,0 @@
-// RCS: @(#) $Id: tcl.rc,v 1.5 2000/04/18 23:26:45 redman Exp $
-//
-// Version
-//
-
-#define VS_VERSION_INFO 1
-
-#define RESOURCE_INCLUDED
-#include <tcl.h>
-
-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
- FILEFLAGS 0x0L
- FILEOS 0x4 /* VOS__WINDOWS32 */
- FILETYPE 0x2 /* 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) ".dll\0"
- VALUE "CompanyName", "Scriptics Corporation\0"
- VALUE "FileVersion", TCL_PATCH_LEVEL
- VALUE "LegalCopyright", "Copyright (c) 2000 by Scriptics Corporation\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
deleted file mode 100644
index b8f3e78..0000000
--- a/win/tclAppInit.c
+++ /dev/null
@@ -1,301 +0,0 @@
-/*
- * tclAppInit.c --
- *
- * Provides a default version of the main program and Tcl_AppInit
- * procedure for Tcl applications (without Tk). Note that this
- * program must be built in Win32 console mode to work properly.
- *
- * Copyright (c) 1996-1997 by Sun Microsystems, Inc.
- * Copyright (c) 1998-1999 by Scriptics Corporation.
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * RCS: @(#) $Id: tclAppInit.c,v 1.6 1999/12/02 02:03:37 redman Exp $
- */
-
-#include "tcl.h"
-#include <windows.h>
-#include <locale.h>
-
-#ifdef TCL_TEST
-extern int Procbodytest_Init _ANSI_ARGS_((Tcl_Interp *interp));
-extern int Procbodytest_SafeInit _ANSI_ARGS_((Tcl_Interp *interp));
-extern int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp));
-extern int TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp));
-#ifdef TCL_THREADS
-extern int TclThread_Init _ANSI_ARGS_((Tcl_Interp *interp));
-#endif
-#endif /* TCL_TEST */
-
-static void setargv _ANSI_ARGS_((int *argcPtr, char ***argvPtr));
-
-
-/*
- *----------------------------------------------------------------------
- *
- * main --
- *
- * This is the main program for the application.
- *
- * Results:
- * None: Tcl_Main never returns here, so this procedure never
- * returns either.
- *
- * Side effects:
- * Whatever the application does.
- *
- *----------------------------------------------------------------------
- */
-
-int
-main(argc, argv)
- int argc; /* Number of command-line arguments. */
- char **argv; /* Values of command-line arguments. */
-{
- /*
- * The following #if block allows you to change the AppInit
- * function by using a #define of TCL_LOCAL_APPINIT instead
- * of rewriting this entire file. The #if checks for that
- * #define and uses Tcl_AppInit if it doesn't exist.
- */
-
-#ifndef TCL_LOCAL_APPINIT
-#define TCL_LOCAL_APPINIT Tcl_AppInit
-#endif
- extern int TCL_LOCAL_APPINIT _ANSI_ARGS_((Tcl_Interp *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
- extern int TCL_LOCAL_MAIN_HOOK _ANSI_ARGS_((int *argc, char ***argv));
-#endif
-
- char buffer[MAX_PATH +1];
- char *p;
- /*
- * Set up the default locale to be standard "C" locale so parsing
- * is performed correctly.
- */
-
- setlocale(LC_ALL, "C");
- setargv(&argc, &argv);
-
- /*
- * Replace argv[0] with full pathname of executable, and forward
- * slashes substituted for backslashes.
- */
-
- GetModuleFileName(NULL, buffer, sizeof(buffer));
- argv[0] = buffer;
- for (p = buffer; *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(interp)
- Tcl_Interp *interp; /* Interpreter for application. */
-{
- if (Tcl_Init(interp) == TCL_ERROR) {
- return TCL_ERROR;
- }
-
-#ifdef TCL_TEST
- if (Tcltest_Init(interp) == TCL_ERROR) {
- return TCL_ERROR;
- }
- Tcl_StaticPackage(interp, "Tcltest", Tcltest_Init,
- (Tcl_PackageInitProc *) NULL);
- if (TclObjTest_Init(interp) == TCL_ERROR) {
- return TCL_ERROR;
- }
-#ifdef TCL_THREADS
- if (TclThread_Init(interp) == TCL_ERROR) {
- return TCL_ERROR;
- }
-#endif
- if (Procbodytest_Init(interp) == TCL_ERROR) {
- return TCL_ERROR;
- }
- Tcl_StaticPackage(interp, "procbodytest", Procbodytest_Init,
- Procbodytest_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.
- */
-
- /*
- * 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_SetVar(interp, "tcl_rcFileName", "~/tclshrc.tcl", 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.
- *
- *--------------------------------------------------------------------------
- */
-
-static void
-setargv(argcPtr, argvPtr)
- int *argcPtr; /* Filled with number of argument strings. */
- char ***argvPtr; /* Filled with argument strings (malloc'd). */
-{
- char *cmdLine, *p, *arg, *argSpace;
- char **argv;
- int argc, size, inquote, copy, slashes;
-
- cmdLine = GetCommandLine(); /* INTL: BUG */
-
- /*
- * 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;
- }
- }
- }
- argSpace = (char *) Tcl_Alloc(
- (unsigned) (size * sizeof(char *) + strlen(cmdLine) + 1));
- argv = (char **) argSpace;
- argSpace += size * sizeof(char *);
- 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;
-}
diff --git a/win/tclConfig.sh.in b/win/tclConfig.sh.in
deleted file mode 100644
index 2aff114..0000000
--- a/win/tclConfig.sh.in
+++ /dev/null
@@ -1,174 +0,0 @@
-# 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.
-#
-# RCS: @(#) $Id: tclConfig.sh.in,v 1.3.10.2 2000/07/28 07:58:28 mo Exp $
-
-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.in 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@'
-
-# 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@'
diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c
deleted file mode 100644
index ed4051a..0000000
--- a/win/tclWin32Dll.c
+++ /dev/null
@@ -1,492 +0,0 @@
-/*
- * tclWin32Dll.c --
- *
- * This file contains the DLL entry point.
- *
- * 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.
- *
- * RCS: @(#) $Id: tclWin32Dll.c,v 1.9 2000/03/31 08:52:30 hobbs Exp $
- */
-
-#include "tclWinInt.h"
-
-/*
- * The following data structures are used when loading the thunking
- * library for execing child processes under Win32s.
- */
-
-typedef DWORD (WINAPI UT32PROC)(LPVOID lpBuff, DWORD dwUserDefined,
- LPVOID *lpTranslationList);
-
-typedef BOOL (WINAPI UTREGISTER)(HANDLE hModule, LPCSTR SixteenBitDLL,
- LPCSTR InitName, LPCSTR ProcName, UT32PROC **ThirtyTwoBitThunk,
- FARPROC UT32Callback, LPVOID Buff);
-
-typedef VOID (WINAPI UTUNREGISTER)(HANDLE hModule);
-
-/*
- * The following variables keep track of information about this DLL
- * on a 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? */
-
-/*
- * The following function tables are used to dispatch to either the
- * wide-character or multi-byte versions of the operating system calls,
- * depending on whether the Unicode calls are available.
- */
-
-static TclWinProcs asciiProcs = {
- 0,
-
- (BOOL (WINAPI *)(CONST TCHAR *, LPDCB)) BuildCommDCBA,
- (TCHAR *(WINAPI *)(TCHAR *)) CharLowerA,
- (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *, BOOL)) CopyFileA,
- (BOOL (WINAPI *)(CONST TCHAR *, LPSECURITY_ATTRIBUTES)) CreateDirectoryA,
- (HANDLE (WINAPI *)(CONST TCHAR *, DWORD, DWORD, SECURITY_ATTRIBUTES *,
- DWORD, DWORD, HANDLE)) CreateFileA,
- (BOOL (WINAPI *)(CONST TCHAR *, TCHAR *, LPSECURITY_ATTRIBUTES,
- LPSECURITY_ATTRIBUTES, BOOL, DWORD, LPVOID, CONST TCHAR *,
- LPSTARTUPINFOA, LPPROCESS_INFORMATION)) CreateProcessA,
- (BOOL (WINAPI *)(CONST TCHAR *)) DeleteFileA,
- (HANDLE (WINAPI *)(CONST TCHAR *, WIN32_FIND_DATAT *)) FindFirstFileA,
- (BOOL (WINAPI *)(HANDLE, WIN32_FIND_DATAT *)) FindNextFileA,
- (BOOL (WINAPI *)(WCHAR *, LPDWORD)) GetComputerNameA,
- (DWORD (WINAPI *)(DWORD, WCHAR *)) GetCurrentDirectoryA,
- (DWORD (WINAPI *)(CONST TCHAR *)) GetFileAttributesA,
- (DWORD (WINAPI *)(CONST TCHAR *, DWORD nBufferLength, WCHAR *,
- TCHAR **)) GetFullPathNameA,
- (DWORD (WINAPI *)(HMODULE, WCHAR *, int)) GetModuleFileNameA,
- (DWORD (WINAPI *)(CONST TCHAR *, WCHAR *, DWORD)) GetShortPathNameA,
- (UINT (WINAPI *)(CONST TCHAR *, CONST TCHAR *, UINT uUnique,
- WCHAR *)) GetTempFileNameA,
- (DWORD (WINAPI *)(DWORD, WCHAR *)) GetTempPathA,
- (BOOL (WINAPI *)(CONST TCHAR *, WCHAR *, DWORD, LPDWORD, LPDWORD, LPDWORD,
- WCHAR *, DWORD)) GetVolumeInformationA,
- (HINSTANCE (WINAPI *)(CONST TCHAR *)) LoadLibraryA,
- (TCHAR (WINAPI *)(WCHAR *, CONST TCHAR *)) lstrcpyA,
- (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *)) MoveFileA,
- (BOOL (WINAPI *)(CONST TCHAR *)) RemoveDirectoryA,
- (DWORD (WINAPI *)(CONST TCHAR *, CONST TCHAR *, CONST TCHAR *, DWORD,
- WCHAR *, TCHAR **)) SearchPathA,
- (BOOL (WINAPI *)(CONST TCHAR *)) SetCurrentDirectoryA,
- (BOOL (WINAPI *)(CONST TCHAR *, DWORD)) SetFileAttributesA,
-};
-
-static TclWinProcs unicodeProcs = {
- 1,
-
- (BOOL (WINAPI *)(CONST TCHAR *, LPDCB)) BuildCommDCBW,
- (TCHAR *(WINAPI *)(TCHAR *)) CharLowerW,
- (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *, BOOL)) CopyFileW,
- (BOOL (WINAPI *)(CONST TCHAR *, LPSECURITY_ATTRIBUTES)) CreateDirectoryW,
- (HANDLE (WINAPI *)(CONST TCHAR *, DWORD, DWORD, SECURITY_ATTRIBUTES *,
- DWORD, DWORD, HANDLE)) CreateFileW,
- (BOOL (WINAPI *)(CONST TCHAR *, TCHAR *, LPSECURITY_ATTRIBUTES,
- LPSECURITY_ATTRIBUTES, BOOL, DWORD, LPVOID, CONST TCHAR *,
- LPSTARTUPINFOA, LPPROCESS_INFORMATION)) CreateProcessW,
- (BOOL (WINAPI *)(CONST TCHAR *)) DeleteFileW,
- (HANDLE (WINAPI *)(CONST TCHAR *, WIN32_FIND_DATAT *)) FindFirstFileW,
- (BOOL (WINAPI *)(HANDLE, WIN32_FIND_DATAT *)) FindNextFileW,
- (BOOL (WINAPI *)(WCHAR *, LPDWORD)) GetComputerNameW,
- (DWORD (WINAPI *)(DWORD, WCHAR *)) GetCurrentDirectoryW,
- (DWORD (WINAPI *)(CONST TCHAR *)) GetFileAttributesW,
- (DWORD (WINAPI *)(CONST TCHAR *, DWORD nBufferLength, WCHAR *,
- TCHAR **)) GetFullPathNameW,
- (DWORD (WINAPI *)(HMODULE, WCHAR *, int)) GetModuleFileNameW,
- (DWORD (WINAPI *)(CONST TCHAR *, WCHAR *, DWORD)) GetShortPathNameW,
- (UINT (WINAPI *)(CONST TCHAR *, CONST TCHAR *, UINT uUnique,
- WCHAR *)) GetTempFileNameW,
- (DWORD (WINAPI *)(DWORD, WCHAR *)) GetTempPathW,
- (BOOL (WINAPI *)(CONST TCHAR *, WCHAR *, DWORD, LPDWORD, LPDWORD, LPDWORD,
- WCHAR *, DWORD)) GetVolumeInformationW,
- (HINSTANCE (WINAPI *)(CONST TCHAR *)) LoadLibraryW,
- (TCHAR (WINAPI *)(WCHAR *, CONST TCHAR *)) lstrcpyW,
- (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *)) MoveFileW,
- (BOOL (WINAPI *)(CONST TCHAR *)) RemoveDirectoryW,
- (DWORD (WINAPI *)(CONST TCHAR *, CONST TCHAR *, CONST TCHAR *, DWORD,
- WCHAR *, TCHAR **)) SearchPathW,
- (BOOL (WINAPI *)(CONST TCHAR *)) SetCurrentDirectoryW,
- (BOOL (WINAPI *)(CONST TCHAR *, DWORD)) SetFileAttributesW,
-};
-
-TclWinProcs *tclWinProcs;
-static Tcl_Encoding tclWinTCharEncoding;
-
-/*
- * The following declaration is for the VC++ DLL entry point.
- */
-
-BOOL APIENTRY DllMain(HINSTANCE hInst, DWORD reason,
- LPVOID reserved);
-
-
-#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(hInst, reason, reserved)
- 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:
- * Establishes 32-to-16 bit thunk and initializes sockets library.
- *
- *----------------------------------------------------------------------
- */
-BOOL APIENTRY
-DllMain(hInst, reason, reserved)
- HINSTANCE hInst; /* Library instance handle. */
- DWORD reason; /* Reason this function is being called. */
- LPVOID reserved; /* Not used. */
-{
- switch (reason) {
- case DLL_PROCESS_ATTACH:
- TclWinInit(hInst);
- return TRUE;
-
- case DLL_PROCESS_DETACH:
- if (hInst == hInstance) {
- Tcl_Finalize();
- }
- break;
- }
-
- 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()
-{
- return hInstance;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclWinInit --
- *
- * This function initializes the internal state of the tcl library.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Initializes the tclPlatformId variable.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclWinInit(hInst)
- HINSTANCE hInst; /* Library instance handle. */
-{
- OSVERSIONINFO os;
-
- hInstance = hInst;
- os.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
- GetVersionEx(&os);
- platformId = os.dwPlatformId;
-
- /*
- * We no longer support Win32s, so just in case someone manages to
- * get a runtime there, make sure they know that.
- */
-
- if (platformId == VER_PLATFORM_WIN32s) {
- panic("Win32s is not a supported platform");
- }
-
- tclWinProcs = &asciiProcs;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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.
- * VER_PLATFORM_WIN32_NT Win32 on Windows NT
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclWinGetPlatformId()
-{
- 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;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclpCheckStackSpace --
- *
- * Detect if we are about to blow the stack. Called before an
- * evaluation can happen when nesting depth is checked.
- *
- * Results:
- * 1 if there is enough stack space to continue; 0 if not.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclpCheckStackSpace()
-{
- /*
- * We can recurse only if there is at least TCL_WIN_STACK_THRESHOLD
- * bytes of stack space left. alloca() is cheap on windows; basically
- * it just subtracts from the stack pointer causing the OS to throw an
- * exception if the stack pointer is set below the bottom of the stack.
- */
-
- __try {
- alloca(TCL_WIN_STACK_THRESHOLD);
- return 1;
- } __except (1) {}
-
- return 0;
-}
-
-
-/*
- *----------------------------------------------------------------------
- *
- * TclWinGetPlatform --
- *
- * This is a kludge that allows the test library to get access
- * the internal tclPlatform variable.
- *
- * Results:
- * Returns a pointer to the tclPlatform variable.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-TclPlatformType *
-TclWinGetPlatform()
-{
- return &tclPlatform;
-}
-
-/*
- *---------------------------------------------------------------------------
- *
- * TclWinSetInterfaces --
- *
- * A helper proc that allows the test library to change the
- * tclWinProcs structure to dispatch to either the wide-character
- * or multi-byte versions of the operating system calls, depending
- * on whether Unicode is the system encoding.
- *
- * Results:
- * None.
- *
- * Side effects:
- * None.
- *
- *---------------------------------------------------------------------------
- */
-
-void
-TclWinSetInterfaces(
- int wide) /* Non-zero to use wide interfaces, 0
- * otherwise. */
-{
- Tcl_FreeEncoding(tclWinTCharEncoding);
-
- if (wide) {
- tclWinProcs = &unicodeProcs;
- tclWinTCharEncoding = Tcl_GetEncoding(NULL, "unicode");
- } else {
- tclWinProcs = &asciiProcs;
- tclWinTCharEncoding = NULL;
- }
-}
-
-/*
- *---------------------------------------------------------------------------
- *
- * 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(string, len, dsPtr)
- 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(tclWinTCharEncoding,
- string, len, dsPtr);
-}
-
-char *
-Tcl_WinTCharToUtf(string, len, dsPtr)
- 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(tclWinTCharEncoding,
- (CONST char *) string, len, dsPtr);
-}
diff --git a/win/tclWinChan.c b/win/tclWinChan.c
deleted file mode 100644
index d6fa836..0000000
--- a/win/tclWinChan.c
+++ /dev/null
@@ -1,1100 +0,0 @@
-/*
- * 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.
- *
- * RCS: @(#) $Id: tclWinChan.c,v 1.10.2.1 2000/07/27 01:39:24 hobbs Exp $
- */
-
-#include "tclWinInt.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. */
-} FileInfo;
-
-typedef struct ThreadSpecificData {
- /*
- * 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 FileEvent {
- 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 _ANSI_ARGS_((ClientData instanceData,
- int mode));
-static void FileChannelExitHandler _ANSI_ARGS_((
- ClientData clientData));
-static void FileCheckProc _ANSI_ARGS_((ClientData clientData,
- int flags));
-static int FileCloseProc _ANSI_ARGS_((ClientData instanceData,
- Tcl_Interp *interp));
-static int FileEventProc _ANSI_ARGS_((Tcl_Event *evPtr,
- int flags));
-static int FileGetHandleProc _ANSI_ARGS_((ClientData instanceData,
- int direction, ClientData *handlePtr));
-static ThreadSpecificData *FileInit _ANSI_ARGS_((void));
-static int FileInputProc _ANSI_ARGS_((ClientData instanceData,
- char *buf, int toRead, int *errorCode));
-static int FileOutputProc _ANSI_ARGS_((ClientData instanceData,
- char *buf, int toWrite, int *errorCode));
-static int FileSeekProc _ANSI_ARGS_((ClientData instanceData,
- long offset, int mode, int *errorCode));
-static void FileSetupProc _ANSI_ARGS_((ClientData clientData,
- int flags));
-static void FileWatchProc _ANSI_ARGS_((ClientData instanceData,
- int mask));
-
-
-/*
- * This structure describes the channel type structure for file based IO.
- */
-
-static Tcl_ChannelType fileChannelType = {
- "file", /* Type name. */
- TCL_CHANNEL_VERSION_2, /* v2 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. */
-};
-
-
-/*
- *----------------------------------------------------------------------
- *
- * 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()
-{
- 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 clientData; /* Old window proc */
-{
- Tcl_DeleteEventSource(FileSetupProc, FileCheckProc, NULL);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * FileSetupProc --
- *
- * This procedure is invoked before Tcl_DoOneEvent blocks waiting
- * for an event.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Adjusts the block time if needed.
- *
- *----------------------------------------------------------------------
- */
-
-void
-FileSetupProc(data, flags)
- 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 procedure is called by Tcl_DoOneEvent to check the file
- * event source for events.
- *
- * Results:
- * None.
- *
- * Side effects:
- * May queue an event.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-FileCheckProc(data, flags)
- 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 = (FileEvent *) 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 procedure 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(evPtr, flags)
- 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(instanceData, mode)
- ClientData instanceData; /* Instance data for channel. */
- int mode; /* TCL_MODE_BLOCKING or
- * TCL_MODE_NONBLOCKING. */
-{
- FileInfo *infoPtr = (FileInfo *) 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(instanceData, interp)
- ClientData instanceData; /* Pointer to FileInfo structure. */
- Tcl_Interp *interp; /* Not used. */
-{
- FileInfo *fileInfoPtr = (FileInfo *) instanceData;
- FileInfo **nextPtrPtr;
- int errorCode = 0;
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
-
- /*
- * 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 exit process. Otherwise, one thread may kill the stdio
- * of another.
- */
-
- if (!TclInExit()
- || ((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;
- }
- }
- for (nextPtrPtr = &(tsdPtr->firstFilePtr); (*nextPtrPtr) != NULL;
- nextPtrPtr = &((*nextPtrPtr)->nextPtr)) {
- if ((*nextPtrPtr) == fileInfoPtr) {
- (*nextPtrPtr) = fileInfoPtr->nextPtr;
- break;
- }
- }
- ckfree((char *)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(instanceData, offset, mode, errorCodePtr)
- 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 = (FileInfo *) instanceData;
- DWORD moveMethod;
- DWORD newPos;
-
- *errorCodePtr = 0;
- if (mode == SEEK_SET) {
- moveMethod = FILE_BEGIN;
- } else if (mode == SEEK_CUR) {
- moveMethod = FILE_CURRENT;
- } else {
- moveMethod = FILE_END;
- }
-
- newPos = SetFilePointer(infoPtr->handle, offset, NULL, moveMethod);
- if (newPos == 0xFFFFFFFF) {
- TclWinConvertError(GetLastError());
- *errorCodePtr = errno;
- return -1;
- }
- return newPos;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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(instanceData, buf, bufSize, errorCode)
- ClientData instanceData; /* File 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. */
-{
- FileInfo *infoPtr;
- DWORD bytesRead;
-
- *errorCode = 0;
- infoPtr = (FileInfo *) instanceData;
-
- /*
- * 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(instanceData, buf, toWrite, errorCode)
- ClientData instanceData; /* File state. */
- char *buf; /* The data buffer. */
- int toWrite; /* How many bytes to write? */
- int *errorCode; /* Where to store error code. */
-{
- FileInfo *infoPtr = (FileInfo *) 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;
- }
- FlushFileBuffers(infoPtr->handle);
- 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(instanceData, mask)
- ClientData instanceData; /* File state. */
- int mask; /* What events to watch for; OR-ed
- * combination of TCL_READABLE,
- * TCL_WRITABLE and TCL_EXCEPTION. */
-{
- FileInfo *infoPtr = (FileInfo *) 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(instanceData, direction, handlePtr)
- ClientData instanceData; /* The file state. */
- int direction; /* TCL_READABLE or TCL_WRITABLE */
- ClientData *handlePtr; /* Where to store the handle. */
-{
- FileInfo *infoPtr = (FileInfo *) 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(interp, fileName, modeString, permissions)
- Tcl_Interp *interp; /* Interpreter for error reporting;
- * can be NULL. */
- char *fileName; /* Name of file to open. */
- char *modeString; /* A list of POSIX open modes or
- * a string such as "rw". */
- int permissions; /* If the open involves creating a
- * file, with what modes to create
- * it? */
-{
- Tcl_Channel channel = 0;
- int seekFlag, mode, channelPermissions;
- DWORD accessMode, createMode, shareMode, flags, consoleParams, type;
- TCHAR *nativeName;
- Tcl_DString ds, buffer;
- DCB dcb;
- HANDLE handle;
- char channelName[16 + TCL_INTEGER_SPACE];
- TclFile readFile = NULL;
- TclFile writeFile = NULL;
-
- mode = TclGetOpenMode(interp, modeString, &seekFlag);
- if (mode == -1) {
- return NULL;
- }
-
- if (Tcl_TranslateFileName(interp, fileName, &ds) == NULL) {
- return NULL;
- }
- nativeName = Tcl_WinUtfToTChar(Tcl_DStringValue(&ds),
- Tcl_DStringLength(&ds), &buffer);
-
- 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:
- 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;
- }
-
- /*
- * 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 = (*tclWinProcs->getFileAttributesProc)(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 = (*tclWinProcs->createFileProc)(nativeName, accessMode,
- shareMode, NULL, createMode, flags, (HANDLE) NULL);
-
- 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);
- if (interp != (Tcl_Interp *) NULL) {
- Tcl_AppendResult(interp, "couldn't open \"", fileName, "\": ",
- Tcl_PosixError(interp), (char *) NULL);
- }
- Tcl_DStringFree(&buffer);
- return NULL;
- }
-
- 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) {
- if (GetConsoleMode(handle, &consoleParams)) {
- type = FILE_TYPE_CONSOLE;
- } else {
- dcb.DCBlength = sizeof( DCB ) ;
- if (GetCommState(handle, &dcb)) {
- type = FILE_TYPE_SERIAL;
- }
-
- }
- }
-
- channel = NULL;
-
- switch (type) {
- case FILE_TYPE_SERIAL:
- 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_AppendResult(interp, "couldn't open \"", fileName, "\": ",
- "bad file type", (char *) NULL);
- break;
- }
-
- Tcl_DStringFree(&buffer);
- Tcl_DStringFree(&ds);
-
- if (channel != NULL) {
- if (seekFlag) {
- if (Tcl_Seek(channel, 0, SEEK_END) < 0) {
- if (interp != (Tcl_Interp *) NULL) {
- Tcl_AppendResult(interp,
- "could not seek to end of file on \"",
- channelName, "\": ", Tcl_PosixError(interp),
- (char *) NULL);
- }
- Tcl_Close(NULL, channel);
- return NULL;
- }
- }
- }
- 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(rawHandle, mode)
- ClientData rawHandle; /* OS level handle */
- int mode; /* ORed combination of TCL_READABLE and
- * TCL_WRITABLE to indicate file mode. */
-{
- char channelName[16 + TCL_INTEGER_SPACE];
- Tcl_Channel channel = NULL;
- HANDLE handle = (HANDLE) rawHandle;
- DCB dcb;
- DWORD consoleParams;
- DWORD type;
- TclFile readFile = NULL;
- TclFile writeFile = NULL;
-
- if (mode == 0) {
- return NULL;
- }
-
- 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) {
- if (GetConsoleMode(handle, &consoleParams)) {
- type = FILE_TYPE_CONSOLE;
- } else {
- dcb.DCBlength = sizeof( DCB ) ;
- if (GetCommState(handle, &dcb)) {
- type = FILE_TYPE_SERIAL;
- }
- }
- }
-
- switch (type)
- {
- 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:
- case FILE_TYPE_UNKNOWN:
- channel = TclWinOpenFileChannel(handle, channelName, mode, 0);
- break;
-
- default:
- /*
- * The handle is of an unknown type, probably /dev/nul equivalent
- * or possibly a closed handle.
- */
-
- channel = NULL;
- break;
-
- }
-
- 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(type)
- int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */
-{
- Tcl_Channel channel;
- HANDLE handle;
- int mode;
- char *bufMode;
- DWORD handleId; /* 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:
- 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 NULL;
- }
-
- channel = Tcl_MakeFileChannel(handle, mode);
-
- if (channel == NULL) {
- return NULL;
- }
-
- /*
- * Set up the normal channel options for stdio handles.
- */
-
- if ((Tcl_SetChannelOption((Tcl_Interp *) NULL, channel, "-translation",
- "auto") == TCL_ERROR)
- || (Tcl_SetChannelOption((Tcl_Interp *) NULL, channel, "-eofchar",
- "\032 {}") == TCL_ERROR)
- || (Tcl_SetChannelOption((Tcl_Interp *) NULL, channel,
- "-buffering", bufMode) == TCL_ERROR)) {
- Tcl_Close((Tcl_Interp *) 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, channelName, permissions, appendMode)
- HANDLE handle;
- char *channelName;
- int permissions;
- int appendMode;
-{
- FileInfo *infoPtr;
- ThreadSpecificData *tsdPtr;
-
- 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 = (FileInfo *) ckalloc((unsigned) sizeof(FileInfo));
- infoPtr->nextPtr = tsdPtr->firstFilePtr;
- tsdPtr->firstFilePtr = infoPtr;
- infoPtr->validMask = permissions;
- infoPtr->watchMask = 0;
- infoPtr->flags = appendMode;
- infoPtr->handle = handle;
-
- wsprintfA(channelName, "file%lx", (int) infoPtr);
-
- infoPtr->channel = Tcl_CreateChannel(&fileChannelType, channelName,
- (ClientData) 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;
-}
-
diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c
deleted file mode 100644
index 579900e..0000000
--- a/win/tclWinConsole.c
+++ /dev/null
@@ -1,1278 +0,0 @@
-/*
- * 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.
- *
- * RCS: @(#) $Id: tclWinConsole.c,v 1.3.10.1 2000/07/27 01:39:25 hobbs Exp $
- */
-
-#include "tclWinInt.h"
-
-#include <dos.h>
-#include <fcntl.h>
-#include <io.h>
-#include <sys/stat.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)
-/*
- * 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. */
- HANDLE writeThread; /* Handle to writer thread. */
- HANDLE readThread; /* Handle to reader thread. */
- HANDLE writable; /* Manual-reset event to signal when the
- * writer thread has finished waiting for
- * the current buffer to be written. */
- HANDLE readable; /* Manual-reset event to signal when the
- * reader thread has finished waiting for
- * input. */
- HANDLE startWriter; /* Auto-reset event used by the main thread to
- * signal when the writer thread should attempt
- * to write to the console. */
- HANDLE startReader; /* Auto-reset event used by the main thread to
- * signal when the reader thread should attempt
- * to read from the console. */
- 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 ThreadSpecificData {
- /*
- * 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 ConsoleEvent {
- 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 ApplicationType(Tcl_Interp *interp,
- const char *fileName, char *fullName);
-static void BuildCommandLine(const char *executable, int argc,
- char **argv, Tcl_DString *linePtr);
-static void CopyChannel(HANDLE dst, HANDLE src);
-static BOOL HasConsole(void);
-static TclFile MakeFile(HANDLE handle);
-static char * MakeTempFile(Tcl_DString *namePtr);
-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 ThreadSpecificData *ConsoleInit(void);
-static int ConsoleInputProc(ClientData instanceData, char *buf,
- int toRead, int *errorCode);
-static int ConsoleOutputProc(ClientData instanceData, 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 TempFileName(WCHAR name[MAX_PATH]);
-static int WaitForRead(ConsoleInfo *infoPtr, int blocking);
-
-/*
- * This structure describes the channel type structure for command console
- * based IO.
- */
-
-static Tcl_ChannelType consoleChannelType = {
- "console", /* Type name. */
- TCL_CHANNEL_VERSION_2, /* v2 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. */
-};
-
-/*
- *----------------------------------------------------------------------
- *
- * ConsoleInit --
- *
- * This function initializes the static variables for this file.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Creates a new event source.
- *
- *----------------------------------------------------------------------
- */
-
-static ThreadSpecificData *
-ConsoleInit()
-{
- ThreadSpecificData *tsdPtr;
-
- /*
- * 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);
- }
-
- tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
- if (tsdPtr == NULL) {
- tsdPtr = TCL_TSD_INIT(&dataKey);
- tsdPtr->firstConsolePtr = NULL;
- Tcl_CreateEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL);
- Tcl_CreateThreadExitHandler(ConsoleExitHandler, NULL);
- }
- return tsdPtr;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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->writable, 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;
- ConsoleEvent *evPtr;
- 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->writable, 0) != WAIT_TIMEOUT) {
- needEvent = 1;
- }
- }
-
- if (infoPtr->watchMask & TCL_READABLE) {
- if (WaitForRead(infoPtr, 0) >= 0) {
- needEvent = 1;
- }
- }
-
- if (needEvent) {
- infoPtr->flags |= CONSOLE_PENDING;
- evPtr = (ConsoleEvent *) ckalloc(sizeof(ConsoleEvent));
- 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 = (ConsoleInfo *) instanceData;
-
- /*
- * Consoles on Windows can not be switched between blocking and nonblocking,
- * hence we have to emulate the behavior. This is done in the input
- * function by checking against a bit in the state. We set or unset the
- * bit here to cause the input function to emulate the correct behavior.
- */
-
- if (mode == TCL_MODE_NONBLOCKING) {
- infoPtr->flags |= CONSOLE_ASYNC;
- } else {
- infoPtr->flags &= ~(CONSOLE_ASYNC);
- }
- return 0;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * ConsoleCloseProc --
- *
- * Closes a console based IO channel.
- *
- * Results:
- * 0 on success, errno otherwise.
- *
- * Side effects:
- * Closes the physical channel.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-ConsoleCloseProc(
- ClientData instanceData, /* Pointer to ConsoleInfo structure. */
- Tcl_Interp *interp) /* For error reporting. */
-{
- ConsoleInfo *consolePtr = (ConsoleInfo *) instanceData;
- int errorCode;
- ConsoleInfo *infoPtr, **nextPtrPtr;
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
-
- errorCode = 0;
-
- /*
- * 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->readThread) {
- /*
- * Forcibly terminate the background thread. We cannot rely on the
- * thread to cleanly terminate itself because we have no way of
- * closing the handle without blocking in the case where the
- * thread is in the middle of an I/O operation. 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);
- TerminateThread(consolePtr->readThread, 0);
-
- /*
- * Wait for the thread to terminate. This ensures that we are
- * completely cleaned up before we leave this function.
- */
-
- WaitForSingleObject(consolePtr->readThread, INFINITE);
- Tcl_MutexUnlock(&consoleMutex);
-
- CloseHandle(consolePtr->readThread);
- CloseHandle(consolePtr->readable);
- CloseHandle(consolePtr->startReader);
- consolePtr->readThread = NULL;
- }
- consolePtr->validMask &= ~TCL_READABLE;
-
- /*
- * Wait for the writer thread to finish the current buffer, then
- * terminate the thread and close the handles. If the channel is
- * nonblocking, there should be no pending write operations.
- */
-
- if (consolePtr->writeThread) {
- WaitForSingleObject(consolePtr->writable, INFINITE);
-
- /*
- * Forcibly terminate the background thread. We cannot rely on the
- * thread to cleanly terminate itself because we have no way of
- * closing the handle without blocking in the case where the
- * thread is in the middle of an I/O operation. 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);
- TerminateThread(consolePtr->writeThread, 0);
-
- /*
- * Wait for the thread to terminate. This ensures that we are
- * completely cleaned up before we leave this function.
- */
-
- WaitForSingleObject(consolePtr->writeThread, INFINITE);
- Tcl_MutexUnlock(&consoleMutex);
-
- CloseHandle(consolePtr->writeThread);
- CloseHandle(consolePtr->writable);
- CloseHandle(consolePtr->startWriter);
- consolePtr->writeThread = NULL;
- }
- consolePtr->validMask &= ~TCL_WRITABLE;
-
-
- /*
- * Don't close the Win32 handle if the handle is a standard channel
- * during the exit process. Otherwise, one thread may kill the stdio
- * of another.
- */
-
- if (!TclInExit()
- || ((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((char*) 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 = (ConsoleInfo *) 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], bufSize);
- bytesRead = bufSize;
- infoPtr->offset += bufSize;
- } else {
- memcpy(buf, &infoPtr->buffer[infoPtr->offset], 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 (ReadConsole(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize, &count,
- (LPOVERLAPPED) NULL) == TRUE) {
- 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. */
- char *buf, /* The data buffer. */
- int toWrite, /* How many bytes to write? */
- int *errorCode) /* Where to store error code. */
-{
- ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData;
- DWORD bytesWritten, timeout;
-
- *errorCode = 0;
- timeout = (infoPtr->flags & CONSOLE_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 = EAGAIN;
- 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, 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(infoPtr->handle, (LPVOID) buf, (DWORD) toWrite,
- &bytesWritten, (LPOVERLAPPED) NULL) == 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->writable, 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 = (ConsoleInfo *) 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 = (ConsoleInfo *) instanceData;
-
- *handlePtr = (ClientData) 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;
- INPUT_RECORD input;
-
- 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 = EAGAIN;
- 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(infoPtr->readable);
- SetEvent(infoPtr->startReader);
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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 = (ConsoleInfo *)arg;
- HANDLE *handle = infoPtr->handle;
- DWORD count;
-
- for (;;) {
- /*
- * Wait for the main thread to signal before attempting to wait.
- */
-
- WaitForSingleObject(infoPtr->startReader, INFINITE);
-
- count = 0;
-
- /*
- * Look for data on the console, but first ignore any events
- * that are not KEY_EVENTs
- */
- if (ReadConsole(handle, infoPtr->buffer, CONSOLE_BUFFER_SIZE,
- &infoPtr->bytesRead, NULL) != FALSE) {
- /*
- * Data was stored in the buffer.
- */
-
- infoPtr->readFlags |= CONSOLE_BUFFERED;
- } else {
- DWORD err;
- err = GetLastError();
-
- if (err == EOF) {
- infoPtr->readFlags = CONSOLE_EOF;
- }
- }
-
- /*
- * 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(&consoleMutex);
- Tcl_ThreadAlert(infoPtr->threadId);
- Tcl_MutexUnlock(&consoleMutex);
- }
- return 0; /* NOT REACHED */
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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 = (ConsoleInfo *)arg;
- HANDLE *handle = infoPtr->handle;
- DWORD count, toWrite;
- char *buf;
-
- for (;;) {
- /*
- * Wait for the main thread to signal before attempting to write.
- */
-
- WaitForSingleObject(infoPtr->startWriter, INFINITE);
-
- 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();
- 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(&consoleMutex);
- Tcl_ThreadAlert(infoPtr->threadId);
- Tcl_MutexUnlock(&consoleMutex);
- }
- return 0; /* NOT REACHED */
-}
-
-
-
-/*
- *----------------------------------------------------------------------
- *
- * 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, channelName, permissions)
- HANDLE handle;
- char *channelName;
- int permissions;
-{
- char encoding[4 + TCL_INTEGER_SPACE];
- ConsoleInfo *infoPtr;
- ThreadSpecificData *tsdPtr;
- DWORD id;
-
- tsdPtr = ConsoleInit();
-
- /*
- * See if a channel with this handle already exists.
- */
-
- infoPtr = (ConsoleInfo *) ckalloc((unsigned) sizeof(ConsoleInfo));
- memset(infoPtr, 0, sizeof(ConsoleInfo));
-
- infoPtr->validMask = permissions;
- infoPtr->handle = handle;
-
- wsprintfA(encoding, "cp%d", GetConsoleCP());
-
- /*
- * 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).
- */
-
- wsprintfA(channelName, "file%lx", (int) infoPtr);
-
- infoPtr->channel = Tcl_CreateChannel(&consoleChannelType, channelName,
- (ClientData) infoPtr, permissions);
-
- infoPtr->threadId = Tcl_GetCurrentThread();
-
- if (permissions & TCL_READABLE) {
- infoPtr->readable = CreateEvent(NULL, TRUE, TRUE, NULL);
- infoPtr->startReader = CreateEvent(NULL, FALSE, FALSE, NULL);
- infoPtr->readThread = CreateThread(NULL, 8000, ConsoleReaderThread,
- infoPtr, 0, &id);
- SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST);
- }
-
- if (permissions & TCL_WRITABLE) {
- infoPtr->writable = CreateEvent(NULL, TRUE, TRUE, NULL);
- infoPtr->startWriter = CreateEvent(NULL, FALSE, FALSE, NULL);
- infoPtr->writeThread = CreateThread(NULL, 8000, ConsoleWriterThread,
- 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 {}");
- Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", encoding);
-
- return infoPtr->channel;
-}
diff --git a/win/tclWinDde.c b/win/tclWinDde.c
deleted file mode 100644
index 2eaf974..0000000
--- a/win/tclWinDde.c
+++ /dev/null
@@ -1,1351 +0,0 @@
-/*
- * tclWinDde.c --
- *
- * This file provides procedures 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.
- *
- * RCS: @(#) $Id: tclWinDde.c,v 1.5 1999/06/26 22:41:53 redman Exp $
- */
-
-#include "tclPort.h"
-#include <ddeml.h>
-
-/*
- * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
- * Registry_Init declaration is in the source file itself, which is only
- * accessed when we are building a library.
- */
-
-#undef TCL_STORAGE_CLASS
-#define TCL_STORAGE_CLASS DLLEXPORT
-
-/*
- * The following 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. */
- char *name; /* Interpreter's name (malloc-ed). */
- 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;
-
-typedef struct ThreadSpecificData {
- 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.1"
-#define TCL_DDE_PACKAGE_NAME "dde"
-#define TCL_DDE_SERVICE_NAME "TclEval"
-
-TCL_DECLARE_MUTEX(ddeMutex)
-
-/*
- * Forward declarations for procedures defined later in this file.
- */
-
-static void DdeExitProc _ANSI_ARGS_((ClientData clientData));
-static void DeleteProc _ANSI_ARGS_((ClientData clientData));
-static Tcl_Obj * ExecuteRemoteObject _ANSI_ARGS_((
- RegisteredInterp *riPtr,
- Tcl_Obj *ddeObjectPtr));
-static int MakeDdeConnection _ANSI_ARGS_((Tcl_Interp *interp,
- char *name, HCONV *ddeConvPtr));
-static HDDEDATA CALLBACK DdeServerProc _ANSI_ARGS_((UINT uType,
- UINT uFmt, HCONV hConv, HSZ ddeTopic,
- HSZ ddeItem, HDDEDATA hData, DWORD dwData1,
- DWORD dwData2));
-static void SetDdeError _ANSI_ARGS_((Tcl_Interp *interp));
-int Tcl_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 */
-
-EXTERN int Dde_Init(Tcl_Interp *interp);
-
-/*
- *----------------------------------------------------------------------
- *
- * Dde_Init --
- *
- * This procedure initializes the dde command.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Dde_Init(
- Tcl_Interp *interp)
-{
- ThreadSpecificData *tsdPtr;
-
- if (!Tcl_InitStubs(interp, "8.0", 0)) {
- return TCL_ERROR;
- }
-
- Tcl_CreateObjCommand(interp, "dde", Tcl_DdeObjCmd, NULL, NULL);
-
- tsdPtr = (ThreadSpecificData *)
- Tcl_GetThreadData((Tcl_ThreadDataKey *) &dataKey, sizeof(ThreadSpecificData));
-
- if (tsdPtr == NULL) {
- tsdPtr = TCL_TSD_INIT(&dataKey);
- tsdPtr->currentConversations = NULL;
- tsdPtr->interpListPtr = NULL;
- }
- Tcl_CreateExitHandler(DdeExitProc, NULL);
-
- return Tcl_PkgProvide(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION);
-}
-
-
-/*
- *----------------------------------------------------------------------
- *
- * 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, 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, 0);
- DdeNameService(ddeInstance, ddeServiceGlobal, 0L, DNS_REGISTER);
- } else {
- ddeIsServer = 0;
- }
- Tcl_MutexUnlock(&ddeMutex);
- }
-}
-
-/*
- *--------------------------------------------------------------
- *
- * DdeSetServerName --
- *
- * This procedure 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 char *
-DdeSetServerName(
- Tcl_Interp *interp,
- char *name /* The name that will be used to
- * refer to the interpreter in later
- * "send" commands. Must be globally
- * unique. */
- )
-{
- int suffix, offset;
- RegisteredInterp *riPtr, *prevPtr;
- Tcl_DString dString;
- 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 "";
- }
-
- /*
- * 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.
- */
-
- suffix = 1;
- offset = 0;
- Tcl_DStringInit(&dString);
-
- /*
- * We have found a unique name. Now add it to the registry.
- */
-
- riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp));
- riPtr->interp = interp;
- riPtr->name = ckalloc(strlen(name) + 1);
- riPtr->nextPtr = tsdPtr->interpListPtr;
- tsdPtr->interpListPtr = riPtr;
- strcpy(riPtr->name, name);
-
- Tcl_CreateObjCommand(interp, "dde", Tcl_DdeObjCmd,
- (ClientData) riPtr, DeleteProc);
- if (Tcl_IsSafe(interp)) {
- Tcl_HideCommand(interp, "dde", "dde");
- }
- Tcl_DStringFree(&dString);
-
- /*
- * re-initialize with the new name
- */
- Initialize();
-
- return riPtr->name;
-}
-
-/*
- *--------------------------------------------------------------
- *
- * DeleteProc
- *
- * This procedure is called when the command "dde" is destroyed.
- *
- * Results:
- * none
- *
- * Side effects:
- * The interpreter given by riPtr is unregistered.
- *
- *--------------------------------------------------------------
- */
-
-static void
-DeleteProc(clientData)
- 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);
- 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 *errorObjPtr;
- Tcl_Obj *returnPackagePtr;
- int result;
-
- result = Tcl_EvalObjEx(riPtr->interp, ddeObjectPtr, TCL_EVAL_GLOBAL);
- returnPackagePtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
- Tcl_ListObjAppendElement(NULL, returnPackagePtr,
- Tcl_NewIntObj(result));
- Tcl_ListObjAppendElement(NULL, returnPackagePtr,
- Tcl_GetObjResult(riPtr->interp));
- if (result == TCL_ERROR) {
- errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorCode", NULL,
- TCL_GLOBAL_ONLY);
- Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr);
- errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorInfo", NULL,
- TCL_GLOBAL_ONLY);
- 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, /* A string handle. Transaction-type
- * dependent. */
- HSZ ddeItem, /* A string handle. Transaction-type
- * dependent. */
- HDDEDATA hData, /* DDE data. Transaction-type dependent. */
- DWORD dwData1, /* Transaction-dependent data. */
- DWORD dwData2) /* Transaction-dependent data. */
-{
- Tcl_DString dString;
- int len;
- char *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, 0);
- Tcl_DStringInit(&dString);
- Tcl_DStringSetLength(&dString, len);
- utilString = Tcl_DStringValue(&dString);
- DdeQueryString(ddeInstance, ddeTopic, utilString, len + 1,
- CP_WINANSI);
-
- for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
- riPtr = riPtr->nextPtr) {
- if (stricmp(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, 0);
- Tcl_DStringInit(&dString);
- Tcl_DStringSetLength(&dString, len);
- utilString = Tcl_DStringValue(&dString);
- DdeQueryString(ddeInstance, ddeTopic, utilString, len + 1,
- CP_WINANSI);
- for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
- riPtr = riPtr->nextPtr) {
- if (stricmp(riPtr->name, utilString) == 0) {
- convPtr = (Conversation *) 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((char *) 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) {
- 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_WINANSI);
- Tcl_DStringInit(&dString);
- Tcl_DStringSetLength(&dString, len);
- utilString = Tcl_DStringValue(&dString);
- DdeQueryString(ddeInstance, ddeItem, utilString,
- len + 1, CP_WINANSI);
- if (stricmp(utilString, "$TCLEVAL$EXECUTE$RESULT") == 0) {
- returnString =
- Tcl_GetStringFromObj(convPtr->returnPackagePtr, &len);
- ddeReturn = DdeCreateDataHandle(ddeInstance,
- returnString, len+1, 0, ddeItem, CF_TEXT,
- 0);
- } else {
- Tcl_Obj *variableObjPtr = Tcl_GetVar2Ex(
- convPtr->riPtr->interp, utilString, NULL,
- TCL_GLOBAL_ONLY);
- if (variableObjPtr != NULL) {
- returnString = Tcl_GetStringFromObj(variableObjPtr,
- &len);
- ddeReturn = DdeCreateDataHandle(ddeInstance,
- returnString, len+1, 0, ddeItem, CF_TEXT, 0);
- } else {
- ddeReturn = NULL;
- }
- }
- Tcl_DStringFree(&dString);
- }
- return ddeReturn;
-
- 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;
-
- for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
- && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
- /*
- * Empty loop body.
- */
-
- }
-
- if (convPtr == NULL) {
- return (HDDEDATA) DDE_FNOTPROCESSED;
- }
-
- utilString = (char *) DdeAccessData(hData, &len);
- ddeObjectPtr = Tcl_NewStringObj(utilString, -1);
- Tcl_IncrRefCount(ddeObjectPtr);
- DdeUnaccessData(hData);
- if (convPtr->returnPackagePtr != NULL) {
- Tcl_DecrRefCount(convPtr->returnPackagePtr);
- }
- convPtr->returnPackagePtr = NULL;
- returnPackagePtr =
- ExecuteRemoteObject(convPtr->riPtr, ddeObjectPtr);
- for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
- && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
- /*
- * Empty loop body.
- */
-
- }
- if (convPtr != NULL) {
- Tcl_IncrRefCount(returnPackagePtr);
- convPtr->returnPackagePtr = 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, &len);
- for (i = 0, riPtr = tsdPtr->interpListPtr; i < numItems;
- i++, riPtr = riPtr->nextPtr) {
- returnPtr[i].hszSvc = DdeCreateStringHandle(
- ddeInstance, "TclEval", CP_WINANSI);
- returnPtr[i].hszTopic = DdeCreateStringHandle(
- ddeInstance, riPtr->name, CP_WINANSI);
- }
- returnPtr[i].hszSvc = NULL;
- returnPtr[i].hszTopic = NULL;
- DdeUnaccessData(ddeReturn);
- return ddeReturn;
- }
-
- }
- 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 procedure 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. */
- char *name, /* The connection to use. */
- HCONV *ddeConvPtr)
-{
- HSZ ddeTopic, ddeService;
- HCONV ddeConv;
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
-
- ddeService = DdeCreateStringHandle(ddeInstance, "TclEval", 0);
- ddeTopic = DdeCreateStringHandle(ddeInstance, name, 0);
-
- ddeConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
- DdeFreeStringHandle(ddeInstance, ddeService);
- DdeFreeStringHandle(ddeInstance, ddeTopic);
-
- if (ddeConv == (HCONV) NULL) {
- if (interp != NULL) {
- Tcl_AppendResult(interp, "no registered server named \"",
- name, "\"", (char *) NULL);
- }
- return TCL_ERROR;
- }
-
- *ddeConvPtr = ddeConv;
- return TCL_OK;
-}
-
-/*
- *--------------------------------------------------------------
- *
- * 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.*/
-{
- Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
- int err;
-
- err = DdeGetLastError(ddeInstance);
- switch (err) {
- case DMLERR_DATAACKTIMEOUT:
- case DMLERR_EXECACKTIMEOUT:
- case DMLERR_POKEACKTIMEOUT:
- Tcl_SetStringObj(resultPtr,
- "remote interpreter did not respond", -1);
- break;
-
- case DMLERR_BUSY:
- Tcl_SetStringObj(resultPtr, "remote server is busy", -1);
- break;
-
- case DMLERR_NOTPROCESSED:
- Tcl_SetStringObj(resultPtr,
- "remote server cannot handle this command", -1);
- break;
-
- default:
- Tcl_SetStringObj(resultPtr, "dde command failed", -1);
- }
-}
-
-/*
- *--------------------------------------------------------------
- *
- * Tcl_DdeObjCmd --
- *
- * This procedure 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.
- *
- *--------------------------------------------------------------
- */
-
-int
-Tcl_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 */
-{
- enum {
- DDE_SERVERNAME,
- DDE_EXECUTE,
- DDE_POKE,
- DDE_REQUEST,
- DDE_SERVICES,
- DDE_EVAL
- };
-
- static char *ddeCommands[] = {"servername", "execute", "poke",
- "request", "services", "eval",
- (char *) NULL};
- static char *ddeOptions[] = {"-async", (char *) NULL};
- int index, argIndex;
- int async = 0;
- int result = TCL_OK;
- HSZ ddeService = NULL;
- HSZ ddeTopic = NULL;
- HSZ ddeItem = NULL;
- HDDEDATA ddeData = NULL;
- HDDEDATA ddeItemData = NULL;
- HCONV hConv = NULL;
- HSZ ddeCookie = 0;
- char *serviceName, *topicName, *itemString, *dataString;
- char *string;
- int firstArg, length, dataLength;
- DWORD ddeResult;
- HDDEDATA ddeReturn;
- RegisteredInterp *riPtr;
- Tcl_Interp *sendInterp;
- Tcl_Obj *objPtr;
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
-
- /*
- * Initialize DDE server/client
- */
-
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "?-async? serviceName topicName value");
- return TCL_ERROR;
- }
-
- if (Tcl_GetIndexFromObj(interp, objv[1], ddeCommands, "command", 0,
- &index) != TCL_OK) {
- return TCL_ERROR;
- }
-
- switch (index) {
- case DDE_SERVERNAME:
- if ((objc != 3) && (objc != 2)) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "servername ?serverName?");
- return TCL_ERROR;
- }
- firstArg = (objc - 1);
- break;
- case DDE_EXECUTE:
- if ((objc < 5) || (objc > 6)) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "execute ?-async? serviceName topicName value");
- return TCL_ERROR;
- }
- if (Tcl_GetIndexFromObj(NULL, objv[2], ddeOptions, "option", 0,
- &argIndex) != TCL_OK) {
- if (objc != 5) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "execute ?-async? serviceName topicName value");
- return TCL_ERROR;
- }
- async = 0;
- firstArg = 2;
- } else {
- if (objc != 6) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "execute ?-async? serviceName topicName value");
- return TCL_ERROR;
- }
- async = 1;
- firstArg = 3;
- }
- break;
- case DDE_POKE:
- if (objc != 6) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "poke serviceName topicName item value");
- return TCL_ERROR;
- }
- firstArg = 2;
- break;
- case DDE_REQUEST:
- if (objc != 5) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "request serviceName topicName value");
- return TCL_ERROR;
- }
- firstArg = 2;
- break;
- case DDE_SERVICES:
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "services serviceName topicName");
- return TCL_ERROR;
- }
- firstArg = 2;
- break;
- case DDE_EVAL:
- if (objc < 4) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "eval ?-async? serviceName args");
- return TCL_ERROR;
- }
- if (Tcl_GetIndexFromObj(NULL, objv[2], ddeOptions, "option", 0,
- &argIndex) != TCL_OK) {
- if (objc < 4) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "eval ?-async? serviceName args");
- return TCL_ERROR;
- }
- async = 0;
- firstArg = 2;
- } else {
- if (objc < 5) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "eval ?-async? serviceName args");
- return TCL_ERROR;
- }
- async = 1;
- firstArg = 3;
- }
- break;
- }
-
- Initialize();
-
- if (firstArg != 1) {
- serviceName = Tcl_GetStringFromObj(objv[firstArg], &length);
- } else {
- length = 0;
- }
-
- if (length == 0) {
- serviceName = NULL;
- } else if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) {
- ddeService = DdeCreateStringHandle(ddeInstance, serviceName,
- CP_WINANSI);
- }
-
- if ((index != DDE_SERVERNAME) &&(index != DDE_EVAL)) {
- topicName = Tcl_GetStringFromObj(objv[firstArg + 1], &length);
- if (length == 0) {
- topicName = NULL;
- } else {
- ddeTopic = DdeCreateStringHandle(ddeInstance,
- topicName, CP_WINANSI);
- }
- }
-
- switch (index) {
- case DDE_SERVERNAME: {
- serviceName = DdeSetServerName(interp, serviceName);
- if (serviceName != NULL) {
- Tcl_SetStringObj(Tcl_GetObjResult(interp),
- serviceName, -1);
- } else {
- Tcl_ResetResult(interp);
- }
- break;
- }
- case DDE_EXECUTE: {
- dataString = Tcl_GetStringFromObj(objv[firstArg + 2], &dataLength);
- if (dataLength == 0) {
- Tcl_SetStringObj(Tcl_GetObjResult(interp),
- "cannot execute null data", -1);
- 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, dataString,
- dataLength+1, 0, 0, CF_TEXT, 0);
- if (ddeData != NULL) {
- if (async) {
- DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, hConv, 0,
- CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
- DdeAbandonTransaction(ddeInstance, hConv,
- ddeResult);
- } else {
- ddeReturn = DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF,
- hConv, 0, CF_TEXT, XTYP_EXECUTE, 30000, NULL);
- if (ddeReturn == 0) {
- SetDdeError(interp);
- result = TCL_ERROR;
- }
- }
- DdeFreeDataHandle(ddeData);
- } else {
- SetDdeError(interp);
- result = TCL_ERROR;
- }
- break;
- }
- case DDE_REQUEST: {
- itemString = Tcl_GetStringFromObj(objv[firstArg + 2], &length);
- if (length == 0) {
- Tcl_SetStringObj(Tcl_GetObjResult(interp),
- "cannot request value of null data", -1);
- return TCL_ERROR;
- }
- 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,
- itemString, CP_WINANSI);
- if (ddeItem != NULL) {
- ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem,
- CF_TEXT, XTYP_REQUEST, 5000, NULL);
- if (ddeData == NULL) {
- SetDdeError(interp);
- result = TCL_ERROR;
- } else {
- dataString = DdeAccessData(ddeData, &dataLength);
- returnObjPtr = Tcl_NewStringObj(dataString, -1);
- DdeUnaccessData(ddeData);
- DdeFreeDataHandle(ddeData);
- Tcl_SetObjResult(interp, returnObjPtr);
- }
- } else {
- SetDdeError(interp);
- result = TCL_ERROR;
- }
- }
-
- break;
- }
- case DDE_POKE: {
- itemString = Tcl_GetStringFromObj(objv[firstArg + 2], &length);
- if (length == 0) {
- Tcl_SetStringObj(Tcl_GetObjResult(interp),
- "cannot have a null item", -1);
- return TCL_ERROR;
- }
- dataString = Tcl_GetStringFromObj(objv[firstArg + 3], &length);
-
- hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
- DdeFreeStringHandle (ddeInstance,ddeService) ;
- DdeFreeStringHandle (ddeInstance, ddeTopic) ;
-
- if (hConv == NULL) {
- SetDdeError(interp);
- result = TCL_ERROR;
- } else {
- ddeItem = DdeCreateStringHandle(ddeInstance, itemString, \
- CP_WINANSI);
- if (ddeItem != NULL) {
- ddeData = DdeClientTransaction(dataString,length+1, \
- hConv, ddeItem,
- CF_TEXT, XTYP_POKE, 5000, NULL);
- if (ddeData == NULL) {
- SetDdeError(interp);
- result = TCL_ERROR;
- }
- } else {
- SetDdeError(interp);
- result = TCL_ERROR;
- }
- }
- break;
- }
-
- case DDE_SERVICES: {
- HCONVLIST hConvList;
- CONVINFO convInfo;
- Tcl_Obj *convListObjPtr, *elementObjPtr;
- Tcl_DString dString;
- char *name;
-
- convInfo.cb = sizeof(CONVINFO);
- hConvList = DdeConnectList(ddeInstance, ddeService,
- ddeTopic, 0, NULL);
- DdeFreeStringHandle (ddeInstance,ddeService) ;
- DdeFreeStringHandle (ddeInstance, ddeTopic) ;
- hConv = 0;
- convListObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
- Tcl_DStringInit(&dString);
-
- while (hConv = DdeQueryNextServer(hConvList, hConv), hConv != 0) {
- elementObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
- DdeQueryConvInfo(hConv, QID_SYNC, &convInfo);
- length = DdeQueryString(ddeInstance,
- convInfo.hszSvcPartner, NULL, 0, CP_WINANSI);
- Tcl_DStringSetLength(&dString, length);
- name = Tcl_DStringValue(&dString);
- DdeQueryString(ddeInstance, convInfo.hszSvcPartner,
- name, length + 1, CP_WINANSI);
- Tcl_ListObjAppendElement(interp, elementObjPtr,
- Tcl_NewStringObj(name, length));
- length = DdeQueryString(ddeInstance, convInfo.hszTopic,
- NULL, 0, CP_WINANSI);
- Tcl_DStringSetLength(&dString, length);
- name = Tcl_DStringValue(&dString);
- DdeQueryString(ddeInstance, convInfo.hszTopic, name,
- length + 1, CP_WINANSI);
- Tcl_ListObjAppendElement(interp, elementObjPtr,
- Tcl_NewStringObj(name, length));
- Tcl_ListObjAppendElement(interp, convListObjPtr, elementObjPtr);
- }
- DdeDisconnectList(hConvList);
- Tcl_SetObjResult(interp, convListObjPtr);
- Tcl_DStringFree(&dString);
- break;
- }
- case DDE_EVAL: {
- objc -= (async + 3);
- ((Tcl_Obj **) objv) += (async + 3);
-
- /*
- * 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 (stricmp(serviceName, riPtr->name) == 0) {
- break;
- }
- }
-
- if (riPtr != NULL) {
- /*
- * This command is to a local interp. No need to go through
- * the server.
- */
-
- Tcl_Preserve((ClientData) riPtr);
- sendInterp = riPtr->interp;
- Tcl_Preserve((ClientData) 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 (objc == 1) {
- result = Tcl_EvalObjEx(sendInterp, objv[0], TCL_EVAL_GLOBAL);
- } else {
- objPtr = Tcl_ConcatObj(objc, objv);
- 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);
- string = Tcl_GetStringFromObj(objPtr, &length);
- Tcl_AddObjErrorInfo(interp, string, length);
-
- objPtr = Tcl_GetVar2Ex(sendInterp, "errorCode", NULL,
- TCL_GLOBAL_ONLY);
- Tcl_SetObjErrorCode(interp, objPtr);
- }
- Tcl_SetObjResult(interp, Tcl_GetObjResult(sendInterp));
- }
- Tcl_Release((ClientData) riPtr);
- Tcl_Release((ClientData) 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) {
- goto error;
- }
-
- objPtr = Tcl_ConcatObj(objc, objv);
- string = Tcl_GetStringFromObj(objPtr, &length);
- ddeItemData = DdeCreateDataHandle(ddeInstance, string, length+1, 0, 0,
- CF_TEXT, 0);
-
- if (async) {
- ddeData = DdeClientTransaction((LPBYTE) ddeItemData, 0xFFFFFFFF, hConv, 0,
- CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
- DdeAbandonTransaction(ddeInstance, hConv, ddeResult);
- } else {
- ddeData = DdeClientTransaction((LPBYTE) ddeItemData, 0xFFFFFFFF, hConv, 0,
- CF_TEXT, XTYP_EXECUTE, 30000, NULL);
- if (ddeData != 0) {
-
- ddeCookie = DdeCreateStringHandle(ddeInstance,
- "$TCLEVAL$EXECUTE$RESULT", CP_WINANSI);
- ddeData = DdeClientTransaction(NULL, 0, hConv, ddeCookie,
- CF_TEXT, XTYP_REQUEST, 30000, NULL);
- }
- }
-
-
- Tcl_DecrRefCount(objPtr);
-
- if (ddeData == 0) {
- SetDdeError(interp);
- goto errorNoResult;
- }
-
- if (async == 0) {
- Tcl_Obj *resultPtr;
-
- /*
- * 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);
- Tcl_SetObjLength(resultPtr, length);
- string = Tcl_GetString(resultPtr);
- DdeGetData(ddeData, string, length, 0);
- Tcl_SetObjLength(resultPtr, strlen(string));
-
- if (Tcl_ListObjIndex(NULL, resultPtr, 0, &objPtr) != TCL_OK) {
- Tcl_DecrRefCount(resultPtr);
- goto error;
- }
- if (Tcl_GetIntFromObj(NULL, objPtr, &result) != TCL_OK) {
- Tcl_DecrRefCount(resultPtr);
- goto error;
- }
- if (result == TCL_ERROR) {
- Tcl_ResetResult(interp);
-
- if (Tcl_ListObjIndex(NULL, resultPtr, 3, &objPtr) != TCL_OK) {
- Tcl_DecrRefCount(resultPtr);
- goto error;
- }
- length = -1;
- string = Tcl_GetStringFromObj(objPtr, &length);
- Tcl_AddObjErrorInfo(interp, string, length);
-
- Tcl_ListObjIndex(NULL, resultPtr, 2, &objPtr);
- Tcl_SetObjErrorCode(interp, objPtr);
- }
- if (Tcl_ListObjIndex(NULL, resultPtr, 1, &objPtr) != TCL_OK) {
- Tcl_DecrRefCount(resultPtr);
- goto error;
- }
- Tcl_SetObjResult(interp, objPtr);
- Tcl_DecrRefCount(resultPtr);
- }
- }
- }
- }
- 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;
-
- error:
- Tcl_SetStringObj(Tcl_GetObjResult(interp),
- "invalid data returned from server", -1);
-
- errorNoResult:
- 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 TCL_ERROR;
-}
diff --git a/win/tclWinError.c b/win/tclWinError.c
deleted file mode 100644
index 7786334..0000000
--- a/win/tclWinError.c
+++ /dev/null
@@ -1,392 +0,0 @@
-/*
- * 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.
- *
- * RCS: @(#) $Id: tclWinError.c,v 1.3 1999/04/16 00:48:08 stanton Exp $
- */
-
-#include "tclWinInt.h"
-
-/*
- * The following table contains the mapping from Win32 errors to
- * errno errors.
- */
-
-static 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 */
- ESRCH, /* ERROR_PROC_NOT_FOUND 127 */
- ECHILD, /* ERROR_WAIT_NO_CHILDREN 128 */
- ECHILD, /* ERROR_CHILD_NOT_COMPLETE 129 */
- EBADF, /* ERROR_DIRECT_ACCESS_HANDLE 130 */
- EINVAL, /* 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 */
-};
-
-static const unsigned int tableLen = sizeof(errorTable);
-
-/*
- * The following table contains the mapping from WinSock errors to
- * errno errors.
- */
-
-static int 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(errCode)
- DWORD errCode; /* Win32 error code. */
-{
- if (errCode >= tableLen) {
- Tcl_SetErrno(EINVAL);
- } else {
- Tcl_SetErrno(errorTable[errCode]);
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclWinConvertWSAError --
- *
- * This routine converts a WinSock error into an errno value.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Sets the errno global variable.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclWinConvertWSAError(errCode)
- DWORD errCode; /* Win32 error code. */
-{
- if ((errCode >= WSAEWOULDBLOCK) && (errCode <= WSAEREMOTE)) {
- Tcl_SetErrno(wsaErrorTable[errCode - WSAEWOULDBLOCK]);
- } else {
- Tcl_SetErrno(EINVAL);
- }
-}
diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c
deleted file mode 100644
index 97eeacb..0000000
--- a/win/tclWinFCmd.c
+++ /dev/null
@@ -1,1664 +0,0 @@
-/*
- * 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.
- *
- * RCS: @(#) $Id: tclWinFCmd.c,v 1.7.2.1 2000/08/07 21:33:02 hobbs Exp $
- */
-
-#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 */
-
-/*
- * Callbacks for file attributes code.
- */
-
-static int GetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp,
- int objIndex, CONST char *fileName,
- Tcl_Obj **attributePtrPtr));
-static int GetWinFileLongName _ANSI_ARGS_((Tcl_Interp *interp,
- int objIndex, CONST char *fileName,
- Tcl_Obj **attributePtrPtr));
-static int GetWinFileShortName _ANSI_ARGS_((Tcl_Interp *interp,
- int objIndex, CONST char *fileName,
- Tcl_Obj **attributePtrPtr));
-static int SetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp,
- int objIndex, CONST char *fileName,
- Tcl_Obj *attributePtr));
-static int CannotSetAttribute _ANSI_ARGS_((Tcl_Interp *interp,
- int objIndex, CONST char *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 int attributeArray[] = {FILE_ATTRIBUTE_ARCHIVE, FILE_ATTRIBUTE_HIDDEN,
- 0, FILE_ATTRIBUTE_READONLY, 0, FILE_ATTRIBUTE_SYSTEM};
-
-
-char *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)(Tcl_DString *srcPtr, Tcl_DString *dstPtr,
- int type, Tcl_DString *errorPtr);
-
-/*
- * Declarations for local procedures defined in this file:
- */
-
-static void StatError(Tcl_Interp *interp, CONST char *fileName);
-static int ConvertFileNameFormat(Tcl_Interp *interp,
- int objIndex, CONST char *fileName, int longShort,
- Tcl_Obj **attributePtrPtr);
-static int DoCopyFile(Tcl_DString *srcPtr, Tcl_DString *dstPtr);
-static int DoCreateDirectory(Tcl_DString *pathPtr);
-static int DoDeleteFile(Tcl_DString *pathPtr);
-static int DoRemoveDirectory(Tcl_DString *pathPtr, int recursive,
- Tcl_DString *errorPtr);
-static int DoRenameFile(const TCHAR *nativeSrc, Tcl_DString *dstPtr);
-static int TraversalCopy(Tcl_DString *srcPtr, Tcl_DString *dstPtr,
- int type, Tcl_DString *errorPtr);
-static int TraversalDelete(Tcl_DString *srcPtr, Tcl_DString *dstPtr,
- int type, Tcl_DString *errorPtr);
-static int TraverseWinTree(TraversalProc *traverseProc,
- Tcl_DString *sourcePtr, Tcl_DString *dstPtr,
- Tcl_DString *errorPtr);
-
-
-/*
- *---------------------------------------------------------------------------
- *
- * TclpRenameFile, 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
-TclpRenameFile(
- CONST char *src, /* Pathname of file or dir to be renamed
- * (UTF-8). */
- CONST char *dst) /* New pathname of file or directory
- * (UTF-8). */
-{
- int result;
- TCHAR *nativeSrc;
- Tcl_DString srcString, dstString;
-
- nativeSrc = Tcl_WinUtfToTChar(src, -1, &srcString);
- Tcl_WinUtfToTChar(dst, -1, &dstString);
-
- result = DoRenameFile(nativeSrc, &dstString);
- Tcl_DStringFree(&srcString);
- Tcl_DStringFree(&dstString);
- return result;
-}
-
-static int
-DoRenameFile(
- CONST TCHAR *nativeSrc, /* Pathname of file or dir to be renamed
- * (native). */
- Tcl_DString *dstPtr) /* New pathname for file or directory
- * (native). */
-{
- const TCHAR *nativeDst;
- DWORD srcAttr, dstAttr;
-
- nativeDst = (TCHAR *) Tcl_DStringValue(dstPtr);
-
- /*
- * Would throw an exception under NT if one of the arguments is a
- * char block device.
- */
-
- __try {
- if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) {
- return TCL_OK;
- }
- } __except (-1) {}
-
- TclWinConvertError(GetLastError());
-
- srcAttr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
- dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst);
- if (srcAttr == 0xffffffff) {
- if ((*tclWinProcs->getFullPathNameProc)(nativeSrc, 0, NULL, NULL) >= MAX_PATH) {
- errno = ENAMETOOLONG;
- return TCL_ERROR;
- }
- srcAttr = 0;
- }
- if (dstAttr == 0xffffffff) {
- if ((*tclWinProcs->getFullPathNameProc)(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;
- char **srcArgv, **dstArgv;
- int size, srcArgc, dstArgc;
- WCHAR nativeSrcPath[MAX_PATH];
- WCHAR nativeDstPath[MAX_PATH];
- Tcl_DString srcString, dstString;
- CONST char *src, *dst;
-
- size = (*tclWinProcs->getFullPathNameProc)(nativeSrc, MAX_PATH,
- nativeSrcPath, &nativeSrcRest);
- if ((size == 0) || (size > MAX_PATH)) {
- return TCL_ERROR;
- }
- size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH,
- nativeDstPath, &nativeDstRest);
- if ((size == 0) || (size > MAX_PATH)) {
- return TCL_ERROR;
- }
- (*tclWinProcs->charLowerProc)((TCHAR *) nativeSrcPath);
- (*tclWinProcs->charLowerProc)((TCHAR *) nativeDstPath);
-
- src = Tcl_WinTCharToUtf((TCHAR *) nativeSrcPath, -1, &srcString);
- dst = Tcl_WinTCharToUtf((TCHAR *) nativeDstPath, -1, &dstString);
- if (strncmp(src, dst, (size_t) 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((char *) srcArgv);
- ckfree((char *) 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 (DoRemoveDirectory(dstPtr, 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 ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) {
- return TCL_OK;
- }
-
- /*
- * Some new error has occurred. Don't know what it
- * could be, but report this one.
- */
-
- TclWinConvertError(GetLastError());
- (*tclWinProcs->createDirectoryProc)(nativeDst, NULL);
- (*tclWinProcs->setFileAttributesProc)(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;
- WCHAR tempBuf[MAX_PATH];
-
- size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH,
- tempBuf, &nativeRest);
- if ((size == 0) || (size > MAX_PATH) || (nativeRest == NULL)) {
- return TCL_ERROR;
- }
- nativeTmp = (TCHAR *) tempBuf;
- ((char *) nativeRest)[0] = '\0';
- ((char *) nativeRest)[1] = '\0'; /* In case it's Unicode. */
-
- result = TCL_ERROR;
- nativePrefix = (tclWinProcs->useWide)
- ? (TCHAR *) L"tclr" : (TCHAR *) "tclr";
- if ((*tclWinProcs->getTempFileNameProc)(nativeTmp,
- nativePrefix, 0, tempBuf) != 0) {
- /*
- * Strictly speaking, need the following DeleteFile and
- * MoveFile to be joined as an atomic operation so no
- * other app comes along in the meantime and creates the
- * same temp file.
- */
-
- nativeTmp = (TCHAR *) tempBuf;
- (*tclWinProcs->deleteFileProc)(nativeTmp);
- if ((*tclWinProcs->moveFileProc)(nativeDst, nativeTmp) != FALSE) {
- if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) {
- (*tclWinProcs->setFileAttributesProc)(nativeTmp,
- FILE_ATTRIBUTE_NORMAL);
- (*tclWinProcs->deleteFileProc)(nativeTmp);
- return TCL_OK;
- } else {
- (*tclWinProcs->deleteFileProc)(nativeDst);
- (*tclWinProcs->moveFileProc)(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;
-}
-
-/*
- *---------------------------------------------------------------------------
- *
- * TclpCopyFile, 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
-TclpCopyFile(
- CONST char *src, /* Pathname of file to be copied (UTF-8). */
- CONST char *dst) /* Pathname of file to copy to (UTF-8). */
-{
- int result;
- Tcl_DString srcString, dstString;
-
- Tcl_WinUtfToTChar(src, -1, &srcString);
- Tcl_WinUtfToTChar(dst, -1, &dstString);
- result = DoCopyFile(&srcString, &dstString);
- Tcl_DStringFree(&srcString);
- Tcl_DStringFree(&dstString);
- return result;
-}
-
-static int
-DoCopyFile(
- Tcl_DString *srcPtr, /* Pathname of file to be copied (native). */
- Tcl_DString *dstPtr) /* Pathname of file to copy to (native). */
-{
- CONST TCHAR *nativeSrc, *nativeDst;
-
- nativeSrc = (TCHAR *) Tcl_DStringValue(srcPtr);
- nativeDst = (TCHAR *) Tcl_DStringValue(dstPtr);
-
- /*
- * Would throw an exception under NT if one of the arguments is a char
- * block device.
- */
-
- __try {
- if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) {
- return TCL_OK;
- }
- } __except (-1) {}
-
- TclWinConvertError(GetLastError());
- if (Tcl_GetErrno() == EBADF) {
- Tcl_SetErrno(EACCES);
- return TCL_ERROR;
- }
- if (Tcl_GetErrno() == EACCES) {
- DWORD srcAttr, dstAttr;
-
- srcAttr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
- dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst);
- if (srcAttr != 0xffffffff) {
- if (dstAttr == 0xffffffff) {
- dstAttr = 0;
- }
- if ((srcAttr & FILE_ATTRIBUTE_DIRECTORY) ||
- (dstAttr & FILE_ATTRIBUTE_DIRECTORY)) {
- Tcl_SetErrno(EISDIR);
- }
- if (dstAttr & FILE_ATTRIBUTE_READONLY) {
- (*tclWinProcs->setFileAttributesProc)(nativeDst,
- dstAttr & ~FILE_ATTRIBUTE_READONLY);
- if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) {
- return TCL_OK;
- }
- /*
- * Still can't copy onto dst. Return that error, and
- * restore attributes of dst.
- */
-
- TclWinConvertError(GetLastError());
- (*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr);
- }
- }
- }
- return TCL_ERROR;
-}
-
-/*
- *---------------------------------------------------------------------------
- *
- * TclpDeleteFile, DoDeleteFile --
- *
- * 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
-TclpDeleteFile(
- CONST char *path) /* Pathname of file to be removed (UTF-8). */
-{
- int result;
- Tcl_DString pathString;
-
- Tcl_WinUtfToTChar(path, -1, &pathString);
- result = DoDeleteFile(&pathString);
- Tcl_DStringFree(&pathString);
- return result;
-}
-
-static int
-DoDeleteFile(
- Tcl_DString *pathPtr) /* Pathname of file to be removed (native). */
-{
- DWORD attr;
- CONST TCHAR *nativePath;
-
- nativePath = (TCHAR *) Tcl_DStringValue(pathPtr);
-
- if ((*tclWinProcs->deleteFileProc)(nativePath) != FALSE) {
- return TCL_OK;
- }
- TclWinConvertError(GetLastError());
-
- /*
- * Win32s thinks that "" is the same as "." and then reports EISDIR
- * instead of ENOENT.
- */
-
- if (tclWinProcs->useWide) {
- if (((WCHAR *) nativePath)[0] == '\0') {
- Tcl_SetErrno(ENOENT);
- return TCL_ERROR;
- }
- } else {
- if (((char *) nativePath)[0] == '\0') {
- Tcl_SetErrno(ENOENT);
- return TCL_ERROR;
- }
- }
- if (Tcl_GetErrno() == EACCES) {
- attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
- if (attr != 0xffffffff) {
- if (attr & FILE_ATTRIBUTE_DIRECTORY) {
- /*
- * Windows NT reports removing a directory as EACCES instead
- * of EISDIR.
- */
-
- Tcl_SetErrno(EISDIR);
- } else if (attr & FILE_ATTRIBUTE_READONLY) {
- (*tclWinProcs->setFileAttributesProc)(nativePath,
- attr & ~FILE_ATTRIBUTE_READONLY);
- if ((*tclWinProcs->deleteFileProc)(nativePath) != FALSE) {
- return TCL_OK;
- }
- TclWinConvertError(GetLastError());
- (*tclWinProcs->setFileAttributesProc)(nativePath, attr);
- }
- }
- } else if (Tcl_GetErrno() == ENOENT) {
- attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
- 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;
-}
-
-/*
- *---------------------------------------------------------------------------
- *
- * TclpCreateDirectory --
- *
- * 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
-TclpCreateDirectory(
- CONST char *path) /* Pathname of directory to create (UTF-8). */
-{
- int result;
- Tcl_DString pathString;
-
- Tcl_WinUtfToTChar(path, -1, &pathString);
- result = DoCreateDirectory(&pathString);
- Tcl_DStringFree(&pathString);
- return result;
-}
-
-static int
-DoCreateDirectory(
- Tcl_DString *pathPtr) /* Pathname of directory to create (native). */
-{
- DWORD error;
- CONST TCHAR *nativePath;
-
- nativePath = (TCHAR *) Tcl_DStringValue(pathPtr);
- if ((*tclWinProcs->createDirectoryProc)(nativePath, NULL) == 0) {
- error = GetLastError();
- TclWinConvertError(error);
- return TCL_ERROR;
- }
- return TCL_OK;
-}
-
-/*
- *---------------------------------------------------------------------------
- *
- * TclpCopyDirectory --
- *
- * 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
-TclpCopyDirectory(
- CONST char *src, /* Pathname of directory to be copied
- * (UTF-8). */
- CONST char *dst, /* Pathname of target directory (UTF-8). */
- Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free
- * DString filled with UTF-8 name of file
- * causing error. */
-{
- int result;
- Tcl_DString srcString, dstString;
-
- Tcl_WinUtfToTChar(src, -1, &srcString);
- Tcl_WinUtfToTChar(dst, -1, &dstString);
-
- result = TraverseWinTree(TraversalCopy, &srcString, &dstString, errorPtr);
-
- Tcl_DStringFree(&srcString);
- Tcl_DStringFree(&dstString);
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclpRemoveDirectory, 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
-TclpRemoveDirectory(
- CONST char *path, /* Pathname of directory to be removed
- * (UTF-8). */
- 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 result;
- Tcl_DString pathString;
-
- Tcl_WinUtfToTChar(path, -1, &pathString);
- result = DoRemoveDirectory(&pathString, recursive, errorPtr);
- Tcl_DStringFree(&pathString);
-
- return result;
-}
-
-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. */
-{
- CONST TCHAR *nativePath;
- DWORD attr;
-
- nativePath = (TCHAR *) Tcl_DStringValue(pathPtr);
-
- if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) {
- return TCL_OK;
- }
- TclWinConvertError(GetLastError());
-
- /*
- * Win32s thinks that "" is the same as "." and then reports EACCES
- * instead of ENOENT.
- */
-
-
- if (tclWinProcs->useWide) {
- if (((WCHAR *) nativePath)[0] == '\0') {
- Tcl_SetErrno(ENOENT);
- return TCL_ERROR;
- }
- } else {
- if (((char *) nativePath)[0] == '\0') {
- Tcl_SetErrno(ENOENT);
- return TCL_ERROR;
- }
- }
- if (Tcl_GetErrno() == EACCES) {
- attr = (*tclWinProcs->getFileAttributesProc)(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_READONLY) {
- attr &= ~FILE_ATTRIBUTE_READONLY;
- if ((*tclWinProcs->setFileAttributesProc)(nativePath, attr) == FALSE) {
- goto end;
- }
- if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) {
- return TCL_OK;
- }
- TclWinConvertError(GetLastError());
- (*tclWinProcs->setFileAttributesProc)(nativePath,
- attr | FILE_ATTRIBUTE_READONLY);
- }
-
- /*
- * Windows 95 and Win32s report removing a non-empty directory
- * as EACCES, not EEXIST. If the directory is not empty,
- * change errno so caller knows what's going on.
- */
-
- if (TclWinGetPlatformId() != VER_PLATFORM_WIN32_NT) {
- char *path, *find;
- HANDLE handle;
- WIN32_FIND_DATAA data;
- Tcl_DString buffer;
- int len;
-
- path = (char *) nativePath;
-
- Tcl_DStringInit(&buffer);
- len = strlen(path);
- find = Tcl_DStringAppend(&buffer, path, len);
- if ((len > 0) && (find[len - 1] != '\\')) {
- Tcl_DStringAppend(&buffer, "\\", 1);
- }
- find = Tcl_DStringAppend(&buffer, "*.*", 3);
- handle = FindFirstFileA(find, &data);
- if (handle != INVALID_HANDLE_VALUE) {
- while (1) {
- if ((strcmp(data.cFileName, ".") != 0)
- && (strcmp(data.cFileName, "..") != 0)) {
- /*
- * Found something in this directory.
- */
-
- Tcl_SetErrno(EEXIST);
- break;
- }
- if (FindNextFileA(handle, &data) == FALSE) {
- break;
- }
- }
- FindClose(handle);
- }
- Tcl_DStringFree(&buffer);
- }
- }
- }
- if (Tcl_GetErrno() == ENOTEMPTY) {
- /*
- * The caller depends on EEXIST to signify that the directory is
- * not empty, not ENOTEMPTY.
- */
-
- Tcl_SetErrno(EEXIST);
- }
- if ((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);
- }
-
- end:
- if (errorPtr != NULL) {
- Tcl_WinTCharToUtf(nativePath, -1, errorPtr);
- }
- return TCL_ERROR;
-}
-
-/*
- *---------------------------------------------------------------------------
- *
- * 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). */
- Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free
- * DString filled with UTF-8 name of file
- * causing error. */
-{
- DWORD sourceAttr;
- TCHAR *nativeSource, *nativeErrfile;
- int result, found, sourceLen, targetLen, oldSourceLen, oldTargetLen;
- HANDLE handle;
- WIN32_FIND_DATAT data;
-
- nativeErrfile = NULL;
- result = TCL_OK;
- oldTargetLen = 0; /* lint. */
-
- nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr);
- oldSourceLen = Tcl_DStringLength(sourcePtr);
- sourceAttr = (*tclWinProcs->getFileAttributesProc)(nativeSource);
- if (sourceAttr == 0xffffffff) {
- nativeErrfile = nativeSource;
- goto end;
- }
- if ((sourceAttr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
- /*
- * Process the regular file
- */
-
- return (*traverseProc)(sourcePtr, targetPtr, DOTREE_F, errorPtr);
- }
-
- if (tclWinProcs->useWide) {
- Tcl_DStringAppend(sourcePtr, (char *) L"\\*.*", 4 * sizeof(WCHAR) + 1);
- Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1);
- } else {
- Tcl_DStringAppend(sourcePtr, "\\*.*", 4);
- }
- nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr);
- handle = (*tclWinProcs->findFirstFileProc)(nativeSource, &data);
- if (handle == INVALID_HANDLE_VALUE) {
- /*
- * Can't read directory
- */
-
- TclWinConvertError(GetLastError());
- nativeErrfile = nativeSource;
- goto end;
- }
-
- nativeSource[oldSourceLen + 1] = '\0';
- Tcl_DStringSetLength(sourcePtr, oldSourceLen);
- result = (*traverseProc)(sourcePtr, targetPtr, DOTREE_PRED, errorPtr);
- if (result != TCL_OK) {
- FindClose(handle);
- return result;
- }
-
- sourceLen = oldSourceLen;
-
- if (tclWinProcs->useWide) {
- sourceLen += sizeof(WCHAR);
- Tcl_DStringAppend(sourcePtr, (char *) L"\\", sizeof(WCHAR) + 1);
- Tcl_DStringSetLength(sourcePtr, sourceLen);
- } else {
- sourceLen += 1;
- Tcl_DStringAppend(sourcePtr, "\\", 1);
- }
- if (targetPtr != NULL) {
- oldTargetLen = Tcl_DStringLength(targetPtr);
-
- targetLen = oldTargetLen;
- if (tclWinProcs->useWide) {
- targetLen += sizeof(WCHAR);
- Tcl_DStringAppend(targetPtr, (char *) L"\\", sizeof(WCHAR) + 1);
- Tcl_DStringSetLength(targetPtr, targetLen);
- } else {
- targetLen += 1;
- Tcl_DStringAppend(targetPtr, "\\", 1);
- }
- }
-
- found = 1;
- for ( ; found; found = (*tclWinProcs->findNextFileProc)(handle, &data)) {
- TCHAR *nativeName;
- int len;
-
- if (tclWinProcs->useWide) {
- WCHAR *wp;
-
- wp = data.w.cFileName;
- if (*wp == '.') {
- wp++;
- if (*wp == '.') {
- wp++;
- }
- if (*wp == '\0') {
- continue;
- }
- }
- nativeName = (TCHAR *) data.w.cFileName;
- len = Tcl_UniCharLen(data.w.cFileName) * sizeof(WCHAR);
- } else {
- if ((strcmp(data.a.cFileName, ".") == 0)
- || (strcmp(data.a.cFileName, "..") == 0)) {
- continue;
- }
- nativeName = (TCHAR *) data.a.cFileName;
- len = strlen(data.a.cFileName);
- }
-
- /*
- * 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)(sourcePtr, 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(
- Tcl_DString *srcPtr, /* Source pathname to copy. */
- Tcl_DString *dstPtr, /* 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. */
-{
- TCHAR *nativeDst, *nativeSrc;
- DWORD attr;
-
- switch (type) {
- case DOTREE_F: {
- if (DoCopyFile(srcPtr, dstPtr) == TCL_OK) {
- return TCL_OK;
- }
- break;
- }
- case DOTREE_PRED: {
- if (DoCreateDirectory(dstPtr) == TCL_OK) {
- nativeSrc = (TCHAR *) Tcl_DStringValue(srcPtr);
- nativeDst = (TCHAR *) Tcl_DStringValue(dstPtr);
- attr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
- if ((*tclWinProcs->setFileAttributesProc)(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) {
- nativeDst = (TCHAR *) Tcl_DStringValue(dstPtr);
- Tcl_WinTCharToUtf(nativeDst, -1, errorPtr);
- }
- return TCL_ERROR;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TraversalDelete --
- *
- * Called by procedure TraverseWinTree for every file and
- * directory that it encounters in a directory hierarchy. This
- * procedure 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(
- Tcl_DString *srcPtr, /* Source pathname to delete. */
- Tcl_DString *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. */
-{
- TCHAR *nativeSrc;
-
- switch (type) {
- case DOTREE_F: {
- if (DoDeleteFile(srcPtr) == TCL_OK) {
- return TCL_OK;
- }
- break;
- }
- case DOTREE_PRED: {
- return TCL_OK;
- }
- case DOTREE_POSTD: {
- if (DoRemoveDirectory(srcPtr, 0, NULL) == TCL_OK) {
- return TCL_OK;
- }
- break;
- }
- }
-
- if (errorPtr != NULL) {
- nativeSrc = (TCHAR *) Tcl_DStringValue(srcPtr);
- 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 */
- CONST char *fileName) /* The name of the file which caused the
- * error. */
-{
- TclWinConvertError(GetLastError());
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "could not read \"", fileName, "\": ", Tcl_PosixError(interp),
- (char *) NULL);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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. */
- CONST char *fileName, /* The name of the file. */
- Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
-{
- DWORD result;
- Tcl_DString ds;
- TCHAR *nativeName;
-
- nativeName = Tcl_WinUtfToTChar(fileName, -1, &ds);
- result = (*tclWinProcs->getFileAttributesProc)(nativeName);
- Tcl_DStringFree(&ds);
-
- if (result == 0xffffffff) {
- StatError(interp, fileName);
- return TCL_ERROR;
- }
-
- *attributePtrPtr = Tcl_NewBooleanObj((int) (result & attributeArray[objIndex]));
- 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.
- *
- * 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. */
- CONST char *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;
- char **pathv, **newv;
- char *resultStr;
- Tcl_DString resultDString;
- int result = TCL_OK;
-
- Tcl_SplitPath(fileName, &pathc, &pathv);
- newv = (char **) ckalloc(pathc * sizeof(char *));
-
- if (pathc == 0) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "could not read \"", fileName,
- "\": no such file or directory",
- (char *) NULL);
- result = TCL_ERROR;
- goto cleanup;
- }
-
- for (i = 0; i < pathc; i++) {
- if ((pathv[i][0] == '/')
- || ((strlen(pathv[i]) == 3) && (pathv[i][1] == ':'))
- || (strcmp(pathv[i], ".") == 0)
- || (strcmp(pathv[i], "..") == 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:
- pathv[i][0] = (char) Tcl_UniCharToUpper(UCHAR(pathv[i][0]));
- newv[i] = (char *) ckalloc(strlen(pathv[i]) + 1);
- lstrcpyA(newv[i], pathv[i]);
- } else {
- char *str;
- TCHAR *nativeName;
- Tcl_DString ds;
- WIN32_FIND_DATAT data;
- HANDLE handle;
- DWORD attr;
-
- Tcl_DStringInit(&resultDString);
- str = Tcl_JoinPath(i + 1, pathv, &resultDString);
- nativeName = Tcl_WinUtfToTChar(str, -1, &ds);
- handle = (*tclWinProcs->findFirstFileProc)(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 = (*tclWinProcs->getFileAttributesProc)(nativeName);
- if ((attr != 0xFFFFFFFF) && (attr & FILE_ATTRIBUTE_DIRECTORY)) {
- Tcl_DStringFree(&ds);
- Tcl_DStringFree(&resultDString);
-
- goto simple;
- }
- }
- Tcl_DStringFree(&ds);
- Tcl_DStringFree(&resultDString);
-
- if (handle == INVALID_HANDLE_VALUE) {
- pathc = i - 1;
- StatError(interp, fileName);
- result = TCL_ERROR;
- goto cleanup;
- }
- if (tclWinProcs->useWide) {
- nativeName = (TCHAR *) data.w.cAlternateFileName;
- if (longShort) {
- if (data.w.cFileName[0] != '\0') {
- nativeName = (TCHAR *) data.w.cFileName;
- }
- } else {
- if (data.w.cAlternateFileName[0] == '\0') {
- nativeName = (TCHAR *) data.w.cFileName;
- }
- }
- } else {
- nativeName = (TCHAR *) data.a.cAlternateFileName;
- if (longShort) {
- if (data.a.cFileName[0] != '\0') {
- nativeName = (TCHAR *) data.a.cFileName;
- }
- } else {
- if (data.a.cAlternateFileName[0] == '\0') {
- nativeName = (TCHAR *) data.a.cFileName;
- }
- }
- }
-
- /*
- * 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_WinTCharToUtf(nativeName, -1, &ds);
- newv[i] = ckalloc((unsigned int) (Tcl_DStringLength(&ds) + 1));
- lstrcpyA(newv[i], Tcl_DStringValue(&ds));
- Tcl_DStringFree(&ds);
- FindClose(handle);
- }
- }
-
- Tcl_DStringInit(&resultDString);
- resultStr = Tcl_JoinPath(pathc, newv, &resultDString);
- *attributePtrPtr = Tcl_NewStringObj(resultStr,
- Tcl_DStringLength(&resultDString));
- Tcl_DStringFree(&resultDString);
-
-cleanup:
- for (i = 0; i < pathc; i++) {
- ckfree(newv[i]);
- }
- ckfree((char *) newv);
- ckfree((char *) pathv);
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * GetWinFileLongName --
- *
- * 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
-GetWinFileLongName(
- Tcl_Interp *interp, /* The interp we are using for errors. */
- int objIndex, /* The index of the attribute. */
- CONST char *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. */
- CONST char *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. */
- CONST char *fileName, /* The name of the file. */
- Tcl_Obj *attributePtr) /* The new value of the attribute. */
-{
- DWORD fileAttributes;
- int yesNo;
- int result;
- Tcl_DString ds;
- TCHAR *nativeName;
-
- nativeName = Tcl_WinUtfToTChar(fileName, -1, &ds);
- fileAttributes = (*tclWinProcs->getFileAttributesProc)(nativeName);
-
- if (fileAttributes == 0xffffffff) {
- StatError(interp, fileName);
- result = TCL_ERROR;
- goto end;
- }
-
- result = Tcl_GetBooleanFromObj(interp, attributePtr, &yesNo);
- if (result != TCL_OK) {
- goto end;
- }
-
- if (yesNo) {
- fileAttributes |= (attributeArray[objIndex]);
- } else {
- fileAttributes &= ~(attributeArray[objIndex]);
- }
-
- if (!(*tclWinProcs->setFileAttributesProc)(nativeName, fileAttributes)) {
- StatError(interp, fileName);
- result = TCL_ERROR;
- goto end;
- }
-
- end:
- Tcl_DStringFree(&ds);
-
- 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 pertinant error message.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-CannotSetAttribute(
- Tcl_Interp *interp, /* The interp we are using for errors. */
- int objIndex, /* The index of the attribute. */
- CONST char *fileName, /* The name of the file. */
- Tcl_Obj *attributePtr) /* The new value of the attribute. */
-{
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "cannot set attribute \"", tclpFileAttrStrings[objIndex],
- "\" for file \"", fileName, "\": attribute is readonly",
- (char *) NULL);
- return TCL_ERROR;
-}
-
-
-/*
- *---------------------------------------------------------------------------
- *
- * TclpListVolumes --
- *
- * Lists the currently mounted volumes
- *
- * Results:
- * A standard Tcl result. Will always be TCL_OK, since there is no way
- * that this command can fail. Also, the interpreter's result is set to
- * the list of volumes.
- *
- * Side effects:
- * None
- *
- *---------------------------------------------------------------------------
- */
-
-int
-TclpListVolumes(
- Tcl_Interp *interp) /* Interpreter for returning volume list. */
-{
- Tcl_Obj *resultPtr, *elemPtr;
- char buf[40 * 4]; /* There couldn't be more than 30 drives??? */
- int i;
- char *p;
-
- resultPtr = Tcl_GetObjResult(interp);
-
- /*
- * 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);
- }
- }
- return TCL_OK;
-}
diff --git a/win/tclWinFile.c b/win/tclWinFile.c
deleted file mode 100644
index 1a689ac..0000000
--- a/win/tclWinFile.c
+++ /dev/null
@@ -1,1034 +0,0 @@
-/*
- * 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.
- *
- * RCS: @(#) $Id: tclWinFile.c,v 1.7 1999/12/12 22:46:51 hobbs Exp $
- */
-
-#include "tclWinInt.h"
-#include <sys/stat.h>
-#include <shlobj.h>
-#include <lmaccess.h> /* For TclpGetUserHome(). */
-
-static time_t ToCTime(FILETIME fileTime);
-
-typedef NET_API_STATUS NET_API_FUNCTION NETUSERGETINFOPROC
- (LPWSTR servername, LPWSTR username, DWORD level, LPBYTE *bufptr);
-
-typedef NET_API_STATUS NET_API_FUNCTION NETAPIBUFFERFREEPROC
- (LPVOID Buffer);
-
-typedef NET_API_STATUS NET_API_FUNCTION NETGETDCNAMEPROC
- (LPWSTR servername, LPWSTR domainname, LPBYTE *bufptr);
-
-
-/*
- *---------------------------------------------------------------------------
- *
- * TclpFindExecutable --
- *
- * This procedure computes the absolute path name of the current
- * application, given its argv[0] value.
- *
- * Results:
- * A dirty UTF string that is the path to the executable. At this
- * point we may not know the system encoding. Convert the native
- * string value to UTF using the default encoding. The assumption
- * is that we will still be able to parse the path given the path
- * name contains ASCII string and '/' chars do not conflict with
- * other UTF chars.
- *
- * Side effects:
- * The variable tclNativeExecutableName gets filled in with the file
- * name for the application, if we figured it out. If we couldn't
- * figure it out, tclNativeExecutableName is set to NULL.
- *
- *---------------------------------------------------------------------------
- */
-
-char *
-TclpFindExecutable(argv0)
- CONST char *argv0; /* The value of the application's argv[0]
- * (native). */
-{
- Tcl_DString ds;
- WCHAR wName[MAX_PATH];
-
- if (argv0 == NULL) {
- return NULL;
- }
- if (tclNativeExecutableName != NULL) {
- return tclNativeExecutableName;
- }
-
- /*
- * Under Windows we ignore argv0, and return the path for the file used to
- * create this process.
- */
-
- (*tclWinProcs->getModuleFileNameProc)(NULL, wName, MAX_PATH);
- Tcl_WinTCharToUtf((TCHAR *) wName, -1, &ds);
-
- tclNativeExecutableName = ckalloc((unsigned) (Tcl_DStringLength(&ds) + 1));
- strcpy(tclNativeExecutableName, Tcl_DStringValue(&ds));
- Tcl_DStringFree(&ds);
-
- TclWinNoBackslash(tclNativeExecutableName);
- return tclNativeExecutableName;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclpMatchFilesTypes --
- *
- * This routine is used by the globbing code to search a
- * directory for all files which match a given pattern.
- *
- * Results:
- * If the tail argument is NULL, then the matching files are
- * added to the the interp's result. Otherwise, TclDoGlob is called
- * recursively for each matching subdirectory. The return value
- * is a standard Tcl result indicating whether an error occurred
- * in globbing.
- *
- * Side effects:
- * None.
- *
- *---------------------------------------------------------------------- */
-
-int
-TclpMatchFilesTypes(
- Tcl_Interp *interp, /* Interpreter to receive results. */
- char *separators, /* Directory separators to pass to TclDoGlob. */
- Tcl_DString *dirPtr, /* Contains path to directory to search. */
- char *pattern, /* Pattern to match against. */
- char *tail, /* Pointer to end of pattern. Tail must
- * point to a location in pattern and must
- * not be static.*/
- GlobTypeData *types) /* Object containing list of acceptable types.
- * May be NULL. */
-{
- char drivePat[] = "?:\\";
- const char *message;
- char *dir, *newPattern, *root;
- int matchDotFiles;
- int dirLength, result = TCL_OK;
- Tcl_DString dirString, patternString;
- DWORD attr, volFlags;
- HANDLE handle;
- WIN32_FIND_DATAT data;
- BOOL found;
- Tcl_DString ds;
- TCHAR *nativeName;
- Tcl_Obj *resultPtr;
-
- /*
- * Convert the path to normalized form since some interfaces only
- * accept backslashes. Also, ensure that the directory ends with a
- * separator character.
- */
-
- dirLength = Tcl_DStringLength(dirPtr);
- Tcl_DStringInit(&dirString);
- if (dirLength == 0) {
- Tcl_DStringAppend(&dirString, ".\\", 2);
- } else {
- char *p;
-
- Tcl_DStringAppend(&dirString, Tcl_DStringValue(dirPtr),
- Tcl_DStringLength(dirPtr));
- for (p = Tcl_DStringValue(&dirString); *p != '\0'; p++) {
- if (*p == '/') {
- *p = '\\';
- }
- }
- p--;
- if ((*p != '\\') && (*p != ':')) {
- Tcl_DStringAppend(&dirString, "\\", 1);
- }
- }
- dir = Tcl_DStringValue(&dirString);
-
- /*
- * First verify that the specified path is actually a directory.
- */
-
- nativeName = Tcl_WinUtfToTChar(dir, Tcl_DStringLength(&dirString), &ds);
- attr = (*tclWinProcs->getFileAttributesProc)(nativeName);
- Tcl_DStringFree(&ds);
-
- if ((attr == 0xffffffff) || ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0)) {
- Tcl_DStringFree(&dirString);
- return TCL_OK;
- }
-
- /*
- * Next check the volume information for the directory to see whether
- * comparisons should be case sensitive or not. If the root is null, then
- * we use the root of the current directory. If the root is just a drive
- * specifier, we use the root directory of the given drive.
- */
-
- switch (Tcl_GetPathType(dir)) {
- case TCL_PATH_RELATIVE:
- found = GetVolumeInformationA(NULL, NULL, 0, NULL, NULL,
- &volFlags, NULL, 0);
- break;
- case TCL_PATH_VOLUME_RELATIVE:
- if (dir[0] == '\\') {
- root = NULL;
- } else {
- root = drivePat;
- *root = dir[0];
- }
- found = GetVolumeInformationA(root, NULL, 0, NULL, NULL,
- &volFlags, NULL, 0);
- break;
- case TCL_PATH_ABSOLUTE:
- if (dir[1] == ':') {
- root = drivePat;
- *root = dir[0];
- found = GetVolumeInformationA(root, NULL, 0, NULL, NULL,
- &volFlags, NULL, 0);
- } else if (dir[1] == '\\') {
- char *p;
-
- p = strchr(dir + 2, '\\');
- p = strchr(p + 1, '\\');
- p++;
- nativeName = Tcl_WinUtfToTChar(dir, p - dir, &ds);
- found = (*tclWinProcs->getVolumeInformationProc)(nativeName,
- NULL, 0, NULL, NULL, &volFlags, NULL, 0);
- Tcl_DStringFree(&ds);
- }
- break;
- }
-
- if (found == 0) {
- message = "couldn't read volume information for \"";
- goto error;
- }
-
- /*
- * In Windows, although some volumes may support case sensitivity, Windows
- * doesn't honor case. So in globbing we need to ignore the case
- * of file names.
- */
-
- Tcl_DStringInit(&patternString);
- newPattern = Tcl_DStringAppend(&patternString, pattern, tail - pattern);
- Tcl_UtfToLower(newPattern);
-
- /*
- * We need to check all files in the directory, so append a *.*
- * to the path.
- */
-
- dir = Tcl_DStringAppend(&dirString, "*.*", 3);
- nativeName = Tcl_WinUtfToTChar(dir, -1, &ds);
- handle = (*tclWinProcs->findFirstFileProc)(nativeName, &data);
- Tcl_DStringFree(&ds);
-
- if (handle == INVALID_HANDLE_VALUE) {
- message = "couldn't read directory \"";
- goto error;
- }
-
- /*
- * Clean up the tail pointer. Leave the tail pointing to the
- * first character after the path separator or NULL.
- */
-
- if (*tail == '\\') {
- tail++;
- }
- if (*tail == '\0') {
- tail = NULL;
- } else {
- tail++;
- }
-
- /*
- * Check to see if the pattern needs to compare with dot files.
- */
-
- if ((newPattern[0] == '.')
- || ((pattern[0] == '\\') && (pattern[1] == '.'))) {
- matchDotFiles = 1;
- } else {
- matchDotFiles = 0;
- }
-
- /*
- * Now iterate over all of the files in the directory.
- */
-
- resultPtr = Tcl_GetObjResult(interp);
- for (found = 1; found != 0;
- found = (*tclWinProcs->findNextFileProc)(handle, &data)) {
- TCHAR *nativeMatchResult;
- char *name, *fname;
-
- if (tclWinProcs->useWide) {
- nativeName = (TCHAR *) data.w.cFileName;
- } else {
- nativeName = (TCHAR *) data.a.cFileName;
- }
- name = Tcl_WinTCharToUtf(nativeName, -1, &ds);
-
- /*
- * Check to see if the file matches the pattern. We need to convert
- * the file name to lower case for comparison purposes. 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.
- */
-
- Tcl_UtfToLower(name);
- nativeMatchResult = NULL;
-
- if ((matchDotFiles == 0) && (name[0] == '.')) {
- /*
- * Ignore hidden files.
- */
- } else if (Tcl_StringMatch(name, newPattern) != 0) {
- nativeMatchResult = nativeName;
- }
- Tcl_DStringFree(&ds);
-
- if (nativeMatchResult == NULL) {
- continue;
- }
-
- /*
- * If the file matches, then we need to process the remainder of the
- * path. If there are more characters to process, then ensure matching
- * files are directories and call TclDoGlob. Otherwise, just add the
- * file to the result.
- */
-
- name = Tcl_WinTCharToUtf(nativeMatchResult, -1, &ds);
- Tcl_DStringAppend(dirPtr, name, -1);
- Tcl_DStringFree(&ds);
-
- fname = Tcl_DStringValue(dirPtr);
- nativeName = Tcl_WinUtfToTChar(fname, Tcl_DStringLength(dirPtr), &ds);
- attr = (*tclWinProcs->getFileAttributesProc)(nativeName);
- Tcl_DStringFree(&ds);
-
- if (tail == NULL) {
- int typeOk = 1;
- if (types != NULL) {
- if (types->perm != 0) {
- if (
- ((types->perm & TCL_GLOB_PERM_RONLY) &&
- !(attr & FILE_ATTRIBUTE_READONLY)) ||
- ((types->perm & TCL_GLOB_PERM_HIDDEN) &&
- !(attr & FILE_ATTRIBUTE_HIDDEN)) ||
- ((types->perm & TCL_GLOB_PERM_R) &&
- (TclpAccess(fname, R_OK) != 0)) ||
- ((types->perm & TCL_GLOB_PERM_W) &&
- (TclpAccess(fname, W_OK) != 0)) ||
- ((types->perm & TCL_GLOB_PERM_X) &&
- (TclpAccess(fname, X_OK) != 0))
- ) {
- typeOk = 0;
- }
- }
- if (typeOk && types->type != 0) {
- struct stat buf;
- /*
- * We must match at least one flag to be listed
- */
- typeOk = 0;
- if (TclpLstat(fname, &buf) >= 0) {
- /*
- * In order bcdpfls as in 'find -t'
- */
- if (
- ((types->type & TCL_GLOB_TYPE_BLOCK) &&
- S_ISBLK(buf.st_mode)) ||
- ((types->type & TCL_GLOB_TYPE_CHAR) &&
- S_ISCHR(buf.st_mode)) ||
- ((types->type & TCL_GLOB_TYPE_DIR) &&
- S_ISDIR(buf.st_mode)) ||
- ((types->type & TCL_GLOB_TYPE_PIPE) &&
- S_ISFIFO(buf.st_mode)) ||
- ((types->type & TCL_GLOB_TYPE_FILE) &&
- S_ISREG(buf.st_mode))
-#ifdef S_ISLNK
- || ((types->type & TCL_GLOB_TYPE_LINK) &&
- S_ISLNK(buf.st_mode))
-#endif
-#ifdef S_ISSOCK
- || ((types->type & TCL_GLOB_TYPE_SOCK) &&
- S_ISSOCK(buf.st_mode))
-#endif
- ) {
- typeOk = 1;
- }
- } else {
- /* Posix error occurred */
- }
- }
- }
- if (typeOk) {
- Tcl_ListObjAppendElement(interp, resultPtr,
- Tcl_NewStringObj(fname, Tcl_DStringLength(dirPtr)));
- }
- } else if (attr & FILE_ATTRIBUTE_DIRECTORY) {
- Tcl_DStringAppend(dirPtr, "/", 1);
- result = TclDoGlob(interp, separators, dirPtr, tail, types);
- if (result != TCL_OK) {
- break;
- }
- }
- Tcl_DStringSetLength(dirPtr, dirLength);
- }
-
- FindClose(handle);
- Tcl_DStringFree(&dirString);
- Tcl_DStringFree(&patternString);
-
- return result;
-
- error:
- Tcl_DStringFree(&dirString);
- TclWinConvertError(GetLastError());
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, message, Tcl_DStringValue(dirPtr), "\": ",
- Tcl_PosixError(interp), (char *) NULL);
- return TCL_ERROR;
-}
-
-/*
- * TclpMatchFiles --
- *
- * This function is now obsolete. Call the above function
- * 'TclpMatchFilesTypes' instead.
- */
-int
-TclpMatchFiles(
- Tcl_Interp *interp, /* Interpreter to receive results. */
- char *separators, /* Directory separators to pass to TclDoGlob. */
- Tcl_DString *dirPtr, /* Contains path to directory to search. */
- char *pattern, /* Pattern to match against. */
- char *tail) /* Pointer to end of pattern. Tail must
- * point to a location in pattern and must
- * not be static.*/
-{
- return TclpMatchFilesTypes(interp,separators,dirPtr,pattern,tail,NULL);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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.
- *
- *----------------------------------------------------------------------
- */
-
-char *
-TclpGetUserHome(name, bufferPtr)
- CONST char *name; /* User name for desired home directory. */
- Tcl_DString *bufferPtr; /* Uninitialized or free DString filled
- * with name of user's home directory. */
-{
- char *result;
- HINSTANCE netapiInst;
-
- result = NULL;
-
- Tcl_DStringInit(bufferPtr);
-
- netapiInst = LoadLibraryA("netapi32.dll");
- if (netapiInst != NULL) {
- NETAPIBUFFERFREEPROC *netApiBufferFreeProc;
- NETGETDCNAMEPROC *netGetDCNameProc;
- NETUSERGETINFOPROC *netUserGetInfoProc;
-
- netApiBufferFreeProc = (NETAPIBUFFERFREEPROC *)
- GetProcAddress(netapiInst, "NetApiBufferFree");
- netGetDCNameProc = (NETGETDCNAMEPROC *)
- GetProcAddress(netapiInst, "NetGetDCName");
- netUserGetInfoProc = (NETUSERGETINFOPROC *)
- GetProcAddress(netapiInst, "NetUserGetInfo");
- if ((netUserGetInfoProc != NULL) && (netGetDCNameProc != NULL)
- && (netApiBufferFreeProc != NULL)) {
- USER_INFO_1 *uiPtr;
- Tcl_DString ds;
- int nameLen, badDomain;
- char *domain;
- WCHAR *wName, *wHomeDir, *wDomain;
- WCHAR buf[MAX_PATH];
-
- badDomain = 0;
- nameLen = -1;
- wDomain = NULL;
- domain = strchr(name, '@');
- if (domain != NULL) {
- Tcl_DStringInit(&ds);
- wName = Tcl_UtfToUniCharDString(domain + 1, -1, &ds);
- badDomain = (*netGetDCNameProc)(NULL, wName,
- (LPBYTE *) &wDomain);
- Tcl_DStringFree(&ds);
- nameLen = domain - name;
- }
- if (badDomain == 0) {
- Tcl_DStringInit(&ds);
- wName = Tcl_UtfToUniCharDString(name, nameLen, &ds);
- if ((*netUserGetInfoProc)(wDomain, wName, 1,
- (LPBYTE *) &uiPtr) == 0) {
- wHomeDir = uiPtr->usri1_home_dir;
- if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) {
- Tcl_UniCharToUtfDString(wHomeDir, lstrlenW(wHomeDir),
- bufferPtr);
- } else {
- /*
- * User exists but has no home dir. Return
- * "{Windows Drive}:/users/default".
- */
-
- GetWindowsDirectoryW(buf, MAX_PATH);
- Tcl_UniCharToUtfDString(buf, 2, bufferPtr);
- Tcl_DStringAppend(bufferPtr, "/users/default", -1);
- }
- result = Tcl_DStringValue(bufferPtr);
- (*netApiBufferFreeProc)((void *) uiPtr);
- }
- Tcl_DStringFree(&ds);
- }
- if (wDomain != NULL) {
- (*netApiBufferFreeProc)((void *) wDomain);
- }
- }
- FreeLibrary(netapiInst);
- }
- 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;
-}
-
-/*
- *---------------------------------------------------------------------------
- *
- * TclpAccess --
- *
- * 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.
- *
- *---------------------------------------------------------------------------
- */
-
-int
-TclpAccess(
- CONST char *path, /* Path of file to access (UTF-8). */
- int mode) /* Permission setting. */
-{
- Tcl_DString ds;
- TCHAR *nativePath;
- DWORD attr;
-
- nativePath = Tcl_WinUtfToTChar(path, -1, &ds);
- attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
- Tcl_DStringFree(&ds);
-
- if (attr == 0xffffffff) {
- /*
- * File doesn't exist.
- */
-
- TclWinConvertError(GetLastError());
- return -1;
- }
-
- if ((mode & W_OK) && (attr & FILE_ATTRIBUTE_READONLY)) {
- /*
- * File is not writable.
- */
-
- Tcl_SetErrno(EACCES);
- return -1;
- }
-
- if (mode & X_OK) {
- CONST char *p;
-
- if (attr & FILE_ATTRIBUTE_DIRECTORY) {
- /*
- * Directories are always executable.
- */
-
- return 0;
- }
- p = strrchr(path, '.');
- if (p != NULL) {
- p++;
- if ((stricmp(p, "exe") == 0)
- || (stricmp(p, "com") == 0)
- || (stricmp(p, "bat") == 0)) {
- /*
- * File that ends with .exe, .com, or .bat is executable.
- */
-
- return 0;
- }
- }
- Tcl_SetErrno(EACCES);
- return -1;
- }
-
- return 0;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclpChdir --
- *
- * This function replaces the library version of chdir().
- *
- * Results:
- * See chdir() documentation.
- *
- * Side effects:
- * See chdir() documentation.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclpChdir(path)
- CONST char *path; /* Path to new working directory (UTF-8). */
-{
- int result;
- Tcl_DString ds;
- TCHAR *nativePath;
-
- nativePath = Tcl_WinUtfToTChar(path, -1, &ds);
- result = (*tclWinProcs->setCurrentDirectoryProc)(nativePath);
- Tcl_DStringFree(&ds);
-
- if (result == 0) {
- TclWinConvertError(GetLastError());
- return -1;
- }
- return 0;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclpGetCwd --
- *
- * This function replaces the library version of getcwd().
- *
- * 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.
- *
- *----------------------------------------------------------------------
- */
-
-char *
-TclpGetCwd(interp, bufferPtr)
- Tcl_Interp *interp; /* If non-NULL, used for error reporting. */
- Tcl_DString *bufferPtr; /* Uninitialized or free DString filled
- * with name of current directory. */
-{
- WCHAR buffer[MAX_PATH];
- char *p;
-
- if ((*tclWinProcs->getCurrentDirectoryProc)(MAX_PATH, buffer) == 0) {
- TclWinConvertError(GetLastError());
- if (interp != NULL) {
- Tcl_AppendResult(interp,
- "error getting working directory name: ",
- Tcl_PosixError(interp), (char *) NULL);
- }
- return NULL;
- }
-
- /*
- * Watch for the wierd Windows c:\\UNC syntax.
- */
-
- if (tclWinProcs->useWide) {
- WCHAR *native;
-
- native = (WCHAR *) buffer;
- if ((native[0] != '\0') && (native[1] == ':')
- && (native[2] == '\\') && (native[3] == '\\')) {
- native += 2;
- }
- Tcl_WinTCharToUtf((TCHAR *) native, -1, bufferPtr);
- } else {
- char *native;
-
- native = (char *) buffer;
- if ((native[0] != '\0') && (native[1] == ':')
- && (native[2] == '\\') && (native[3] == '\\')) {
- native += 2;
- }
- Tcl_WinTCharToUtf((TCHAR *) native, -1, bufferPtr);
- }
-
- /*
- * Convert to forward slashes for easier use in scripts.
- */
-
- for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) {
- if (*p == '\\') {
- *p = '/';
- }
- }
- return Tcl_DStringValue(bufferPtr);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclpStat --
- *
- * 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.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclpStat(path, statPtr)
- CONST char *path; /* Path of file to stat (UTF-8). */
- struct stat *statPtr; /* Filled with results of stat call. */
-{
- Tcl_DString ds;
- TCHAR *nativePath;
- WIN32_FIND_DATAT data;
- HANDLE handle;
- DWORD attr;
- WCHAR nativeFullPath[MAX_PATH];
- TCHAR *nativePart;
- char *p, *fullPath;
- int dev, mode;
-
- /*
- * Eliminate file names containing wildcard characters, or subsequent
- * call to FindFirstFile() will expand them, matching some other file.
- */
-
- if (strpbrk(path, "?*") != NULL) {
- Tcl_SetErrno(ENOENT);
- return -1;
- }
-
- nativePath = Tcl_WinUtfToTChar(path, -1, &ds);
- handle = (*tclWinProcs->findFirstFileProc)(nativePath, &data);
- if (handle == INVALID_HANDLE_VALUE) {
- /*
- * FindFirstFile() doesn't work on root directories, so call
- * GetFileAttributes() to see if the specified file exists.
- */
-
- attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
- if (attr == 0xffffffff) {
- Tcl_DStringFree(&ds);
- Tcl_SetErrno(ENOENT);
- return -1;
- }
-
- /*
- * Make up some fake information for this file. It has the
- * correct file attributes and a time of 0.
- */
-
- memset(&data, 0, sizeof(data));
- data.a.dwFileAttributes = attr;
- } else {
- FindClose(handle);
- }
-
- (*tclWinProcs->getFullPathNameProc)(nativePath, MAX_PATH, nativeFullPath,
- &nativePart);
-
- Tcl_DStringFree(&ds);
- fullPath = Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds);
-
- dev = -1;
- if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) {
- char *p;
- DWORD dw;
- 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 = Tcl_DStringAppend(&ds, "\\", 1);
- p = fullPath + Tcl_DStringLength(&ds);
- } else {
- p++;
- }
- nativeVol = Tcl_WinUtfToTChar(fullPath, p - fullPath, &volString);
- dw = (DWORD) -1;
- (*tclWinProcs->getVolumeInformationProc)(nativeVol, NULL, 0, &dw,
- NULL, NULL, NULL, 0);
- /*
- * 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';
- }
- Tcl_DStringFree(&ds);
-
- attr = data.a.dwFileAttributes;
- mode = (attr & FILE_ATTRIBUTE_DIRECTORY) ? S_IFDIR | S_IEXEC : S_IFREG;
- mode |= (attr & FILE_ATTRIBUTE_READONLY) ? S_IREAD : S_IREAD | S_IWRITE;
- p = strrchr(path, '.');
- if (p != NULL) {
- if ((lstrcmpiA(p, ".exe") == 0)
- || (lstrcmpiA(p, ".com") == 0)
- || (lstrcmpiA(p, ".bat") == 0)
- || (lstrcmpiA(p, ".pif") == 0)) {
- mode |= S_IEXEC;
- }
- }
-
- /*
- * Propagate the S_IREAD, S_IWRITE, S_IEXEC bits to the group and
- * other positions.
- */
-
- mode |= (mode & 0x0700) >> 3;
- mode |= (mode & 0x0700) >> 6;
-
- statPtr->st_dev = (dev_t) dev;
- statPtr->st_ino = 0;
- statPtr->st_mode = (unsigned short) mode;
- statPtr->st_nlink = 1;
- statPtr->st_uid = 0;
- statPtr->st_gid = 0;
- statPtr->st_rdev = (dev_t) dev;
- statPtr->st_size = data.a.nFileSizeLow;
- statPtr->st_atime = ToCTime(data.a.ftLastAccessTime);
- statPtr->st_mtime = ToCTime(data.a.ftLastWriteTime);
- statPtr->st_ctime = ToCTime(data.a.ftCreationTime);
- return 0;
-}
-
-static time_t
-ToCTime(
- FILETIME fileTime) /* UTC Time to convert to local time_t. */
-{
- FILETIME localFileTime;
- SYSTEMTIME systemTime;
- struct tm tm;
-
- if (FileTimeToLocalFileTime(&fileTime, &localFileTime) == 0) {
- return 0;
- }
- if (FileTimeToSystemTime(&localFileTime, &systemTime) == 0) {
- return 0;
- }
- tm.tm_sec = systemTime.wSecond;
- tm.tm_min = systemTime.wMinute;
- tm.tm_hour = systemTime.wHour;
- tm.tm_mday = systemTime.wDay;
- tm.tm_mon = systemTime.wMonth - 1;
- tm.tm_year = systemTime.wYear - 1900;
- tm.tm_wday = 0;
- tm.tm_yday = 0;
- tm.tm_isdst = -1;
-
- return mktime(&tm);
-}
-
-#if 0
-
- /*
- * Borland's stat doesn't take into account localtime.
- */
-
- if ((result == 0) && (buf->st_mtime != 0)) {
- TIME_ZONE_INFORMATION tz;
- int time, bias;
-
- time = GetTimeZoneInformation(&tz);
- bias = tz.Bias;
- if (time == TIME_ZONE_ID_DAYLIGHT) {
- bias += tz.DaylightBias;
- }
- bias *= 60;
- buf->st_atime -= bias;
- buf->st_ctime -= bias;
- buf->st_mtime -= bias;
- }
-
-#endif
-
-
-#if 0
-/*
- *-------------------------------------------------------------------------
- *
- * TclWinResolveShortcut --
- *
- * Resolve a potential Windows shortcut to get the actual file or
- * directory in question.
- *
- * Results:
- * Returns 1 if the shortcut could be resolved, or 0 if there was
- * an error or if the filename was not a shortcut.
- * If bufferPtr did hold the name of a shortcut, it is modified to
- * hold the resolved target of the shortcut instead.
- *
- * Side effects:
- * Loads and unloads OLE package to determine if filename refers to
- * a shortcut.
- *
- *-------------------------------------------------------------------------
- */
-
-int
-TclWinResolveShortcut(bufferPtr)
- Tcl_DString *bufferPtr; /* Holds name of file to resolve. On
- * return, holds resolved file name. */
-{
- HRESULT hres;
- IShellLink *psl;
- IPersistFile *ppf;
- WIN32_FIND_DATA wfd;
- WCHAR wpath[MAX_PATH];
- char *path, *ext;
- char realFileName[MAX_PATH];
-
- /*
- * Windows system calls do not automatically resolve
- * shortcuts like UNIX automatically will with symbolic links.
- */
-
- path = Tcl_DStringValue(bufferPtr);
- ext = strrchr(path, '.');
- if ((ext == NULL) || (stricmp(ext, ".lnk") != 0)) {
- return 0;
- }
-
- CoInitialize(NULL);
- path = Tcl_DStringValue(bufferPtr);
- realFileName[0] = '\0';
- hres = CoCreateInstance(&CLSID_ShellLink, NULL, CLSCTX_INPROC_SERVER,
- &IID_IShellLink, &psl);
- if (SUCCEEDED(hres)) {
- hres = psl->lpVtbl->QueryInterface(psl, &IID_IPersistFile, &ppf);
- if (SUCCEEDED(hres)) {
- MultiByteToWideChar(CP_ACP, 0, path, -1, wpath, sizeof(wpath));
- hres = ppf->lpVtbl->Load(ppf, wpath, STGM_READ);
- if (SUCCEEDED(hres)) {
- hres = psl->lpVtbl->Resolve(psl, NULL,
- SLR_ANY_MATCH | SLR_NO_UI);
- if (SUCCEEDED(hres)) {
- hres = psl->lpVtbl->GetPath(psl, realFileName, MAX_PATH,
- &wfd, 0);
- }
- }
- ppf->lpVtbl->Release(ppf);
- }
- psl->lpVtbl->Release(psl);
- }
- CoUninitialize();
-
- if (realFileName[0] != '\0') {
- Tcl_DStringSetLength(bufferPtr, 0);
- Tcl_DStringAppend(bufferPtr, realFileName, -1);
- return 1;
- }
- return 0;
-}
-#endif
diff --git a/win/tclWinInit.c b/win/tclWinInit.c
deleted file mode 100644
index dbf44ea..0000000
--- a/win/tclWinInit.c
+++ /dev/null
@@ -1,845 +0,0 @@
-/*
- * 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.
- *
- * RCS: @(#) $Id: tclWinInit.c,v 1.22 2000/03/31 08:52:31 hobbs Exp $
- */
-
-#include "tclWinInt.h"
-#include <winreg.h>
-#include <winnt.h>
-#include <winbase.h>
-
-/*
- * The following macro can be defined at compile time to specify
- * the root of the Tcl registry keys.
- */
-
-#ifndef TCL_REGISTRY_KEY
-#define TCL_REGISTRY_KEY "Software\\Scriptics\\Tcl\\" TCL_VERSION
-#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_UNKNOWN
-#define PROCESSOR_ARCHITECTURE_UNKNOWN 0xFFFF
-#endif
-
-/*
- * The following arrays contain the human readable strings for the Windows
- * platform and processor values.
- */
-
-
-#define NUMPLATFORMS 3
-static char* platforms[NUMPLATFORMS] = {
- "Win32s", "Windows 95", "Windows NT"
-};
-
-#define NUMPROCESSORS 4
-static char* processors[NUMPROCESSORS] = {
- "intel", "mips", "alpha", "ppc"
-};
-
-/*
- * Thread id used for asynchronous notification from signal handlers.
- */
-
-static DWORD mainThreadId;
-
-/*
- * The Init script (common to Windows and Unix platforms) is
- * defined in tkInitScript.h
- */
-
-#include "tclInitScript.h"
-
-static void AppendEnvironment(Tcl_Obj *listPtr, CONST char *lib);
-static void AppendDllPath(Tcl_Obj *listPtr, HMODULE hModule,
- CONST char *lib);
-static void AppendRegistry(Tcl_Obj *listPtr, CONST char *lib);
-static int ToUtf(CONST WCHAR *wSrc, char *dst);
-
-/*
- *---------------------------------------------------------------------------
- *
- * TclpInitPlatform --
- *
- * Initialize all the platform-dependant things like signals and
- * floating-point error handling.
- *
- * Called at process initialization time.
- *
- * Results:
- * None.
- *
- * Side effects:
- * None.
- *
- *---------------------------------------------------------------------------
- */
-
-void
-TclpInitPlatform()
-{
- tclPlatform = TCL_PLATFORM_WINDOWS;
-
- /*
- * The following code stops Windows 3.X and Windows NT 3.51 from
- * automatically putting up Sharing Violation dialogs, e.g, when
- * someone tries to access a file that is locked or a drive with no
- * disk in it. Tcl already returns the appropriate error to the
- * caller, and they can decide to put up their own dialog in response
- * to that failure.
- *
- * Under 95 and NT 4.0, this is a NOOP because the system doesn't
- * automatically put up dialogs when the above operations fail.
- */
-
- SetErrorMode(SetErrorMode(0) | SEM_FAILCRITICALERRORS);
-
- /*
- * Save the id of the first thread to intialize the Tcl library. This
- * thread will be used to handle notifications from async event
- * procedures. This is not strictly correct. A better solution involves
- * using a designated "main" notifier that is kept up to date as threads
- * come and go.
- */
-
- mainThreadId = GetCurrentThreadId();
-
-#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 --
- *
- * Initialize the library path at startup.
- *
- * This call sets the library path to strings in UTF-8. Any
- * pre-existing library path information is assumed to have been
- * in the native multibyte encoding.
- *
- * Called at process initialization time.
- *
- * Results:
- * None.
- *
- * Side effects:
- * None.
- *
- *---------------------------------------------------------------------------
- */
-
-void
-TclpInitLibraryPath(path)
- CONST char *path; /* Potentially dirty UTF string that is */
- /* the path to the executable name. */
-{
-#define LIBRARY_SIZE 32
- Tcl_Obj *pathPtr, *objPtr;
- char *str;
- Tcl_DString ds;
- int pathc;
- char **pathv;
- char installLib[LIBRARY_SIZE], developLib[LIBRARY_SIZE];
-
- Tcl_DStringInit(&ds);
- pathPtr = Tcl_NewObj();
-
- /*
- * Initialize the substrings used when locating an executable. The
- * installLib variable computes the path as though the executable
- * is installed. The developLib computes the path as though the
- * executable is run from a develpment directory.
- */
-
- sprintf(installLib, "lib/tcl%s", TCL_VERSION);
- sprintf(developLib, "../tcl%s/library",
- ((TCL_RELEASE_LEVEL < 2) ? TCL_PATCH_LEVEL : TCL_VERSION));
-
- /*
- * Look for the library relative to default encoding dir.
- */
-
- str = Tcl_GetDefaultEncodingDir();
- if ((str != NULL) && (str[0] != '\0')) {
- objPtr = Tcl_NewStringObj(str, -1);
- Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
- }
-
- /*
- * 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 relative to the DLL. Only use the installLib
- * because in practice, the DLL is always installed.
- */
-
- AppendDllPath(pathPtr, TclWinGetTclInstance(), installLib);
-
-
- /*
- * Look for the library relative to the executable. This algorithm
- * should be the same as the one in the tcl_findLibrary procedure.
- *
- * This code looks in the following directories:
- *
- * <bindir>/../<installLib>
- * (e.g. /usr/local/bin/../lib/tcl8.2)
- * <bindir>/../../<installLib>
- * (e.g. /usr/local/TclPro/solaris-sparc/bin/../../lib/tcl8.2)
- * <bindir>/../library
- * (e.g. /usr/src/tcl8.2/unix/../library)
- * <bindir>/../../library
- * (e.g. /usr/src/tcl8.2/unix/solaris-sparc/../../library)
- * <bindir>/../../<developLib>
- * (e.g. /usr/src/tcl8.2/unix/../../tcl8.2/library)
- * <bindir>/../../../<devlopLib>
- * (e.g. /usr/src/tcl8.2/unix/solaris-sparc/../../../tcl8.2/library)
- */
-
- if (path != NULL) {
- Tcl_SplitPath(path, &pathc, &pathv);
- if (pathc > 1) {
- pathv[pathc - 2] = installLib;
- path = Tcl_JoinPath(pathc - 1, pathv, &ds);
- objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
- Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
- Tcl_DStringFree(&ds);
- }
- if (pathc > 2) {
- pathv[pathc - 3] = installLib;
- path = Tcl_JoinPath(pathc - 2, pathv, &ds);
- objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
- Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
- Tcl_DStringFree(&ds);
- }
- if (pathc > 1) {
- pathv[pathc - 2] = "library";
- path = Tcl_JoinPath(pathc - 1, pathv, &ds);
- objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
- Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
- Tcl_DStringFree(&ds);
- }
- if (pathc > 2) {
- pathv[pathc - 3] = "library";
- path = Tcl_JoinPath(pathc - 2, pathv, &ds);
- objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
- Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
- Tcl_DStringFree(&ds);
- }
- if (pathc > 1) {
- pathv[pathc - 3] = developLib;
- path = Tcl_JoinPath(pathc - 2, pathv, &ds);
- objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
- Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
- Tcl_DStringFree(&ds);
- }
- if (pathc > 3) {
- pathv[pathc - 4] = developLib;
- path = Tcl_JoinPath(pathc - 3, pathv, &ds);
- objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
- Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
- Tcl_DStringFree(&ds);
- }
- ckfree((char *) pathv);
- }
-
- TclSetLibraryPath(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;
- char *str;
- Tcl_DString ds;
- char **pathv;
-
- /*
- * 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 lib is ascii.
- */
-
- if ((pathc > 0) && (lstrcmpiA(lib + 4, 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] = (char *) (lib + 4);
- Tcl_DStringInit(&ds);
- str = Tcl_JoinPath(pathc, pathv, &ds);
- objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&ds));
- Tcl_DStringFree(&ds);
- } else {
- objPtr = Tcl_NewStringObj(buf, -1);
- }
- Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
- ckfree((char *) pathv);
- }
-}
-
-/*
- *---------------------------------------------------------------------------
- *
- * AppendDllPath --
- *
- * Append a path onto the path pointer that tries to locate the Tcl
- * library relative to the location of the Tcl DLL.
- *
- * Results:
- * None.
- *
- * Side effects:
- * None.
- *
- *---------------------------------------------------------------------------
- */
-
-static void
-AppendDllPath(
- Tcl_Obj *pathPtr,
- HMODULE hModule,
- CONST char *lib)
-{
- WCHAR wName[MAX_PATH + LIBRARY_SIZE];
- char name[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX];
-
- if (GetModuleFileNameW(hModule, wName, MAX_PATH) == 0) {
- GetModuleFileNameA(hModule, name, MAX_PATH);
- } else {
- ToUtf(wName, name);
- }
- if (lib != NULL) {
- char *end, *p;
-
- end = strrchr(name, '\\');
- *end = '\0';
- p = strrchr(name, '\\');
- if (p != NULL) {
- end = p;
- }
- *end = '\\';
- strcpy(end + 1, lib);
- }
- TclWinNoBackslash(name);
- Tcl_ListObjAppendElement(NULL, pathPtr, Tcl_NewStringObj(name, -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 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.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The Tcl library path is converted from native encoding to UTF-8.
- *
- *---------------------------------------------------------------------------
- */
-
-void
-TclpSetInitialEncodings()
-{
- CONST char *encoding;
- char buf[4 + TCL_INTEGER_SPACE];
- int platformId;
- Tcl_Obj *pathPtr;
-
- platformId = TclWinGetPlatformId();
-
- TclWinSetInterfaces(platformId == VER_PLATFORM_WIN32_NT);
-
- wsprintfA(buf, "cp%d", GetACP());
- Tcl_SetSystemEncoding(NULL, buf);
-
- if (platformId != VER_PLATFORM_WIN32_NT) {
- pathPtr = TclGetLibraryPath();
- if (pathPtr != NULL) {
- int i, objc;
- Tcl_Obj **objv;
-
- objc = 0;
- Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv);
- for (i = 0; i < objc; i++) {
- int length;
- char *string;
- Tcl_DString ds;
-
- string = Tcl_GetStringFromObj(objv[i], &length);
- Tcl_ExternalToUtfDString(NULL, string, length, &ds);
- Tcl_SetStringObj(objv[i], Tcl_DStringValue(&ds),
- Tcl_DStringLength(&ds));
- Tcl_DStringFree(&ds);
- }
- }
- }
-
- /*
- * Keep this encoding preloaded. The IO package uses it for gets on a
- * binary channel.
- */
-
- encoding = "iso8859-1";
- Tcl_GetEncoding(NULL, encoding);
-}
-
-/*
- *---------------------------------------------------------------------------
- *
- * TclpSetVariables --
- *
- * Performs platform-specific interpreter initialization related to
- * the tcl_platform and env variables, and other platform-specific
- * things.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Sets "tclDefaultLibrary", "tcl_platform", and "env(HOME)" Tcl
- * variables.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclpSetVariables(interp)
- Tcl_Interp *interp; /* Interp to initialize. */
-{
- char *ptr;
- char buffer[TCL_INTEGER_SPACE * 2];
- SYSTEM_INFO sysInfo;
- OemId *oemId;
- OSVERSIONINFOA osInfo;
- Tcl_DString ds;
-
- osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
- GetVersionExA(&osInfo);
-
- oemId = (OemId *) &sysInfo;
- GetSystemInfo(&sysInfo);
-
- /*
- * Initialize the tclDefaultLibrary variable from the registry.
- */
-
- Tcl_SetVar(interp, "tclDefaultLibrary", "", TCL_GLOBAL_ONLY);
-
- /*
- * 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 (oemId->wProcessorArchitecture < NUMPROCESSORS) {
- Tcl_SetVar2(interp, "tcl_platform", "machine",
- processors[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.
- */
-
- Tcl_DStringSetLength(&ds, 100);
- if (TclGetEnv("USERNAME", &ds) == NULL) {
- if (GetUserName(Tcl_DStringValue(&ds), &Tcl_DStringLength(&ds)) == 0) {
- Tcl_DStringSetLength(&ds, 0);
- }
- }
- Tcl_SetVar2(interp, "tcl_platform", "user", Tcl_DStringValue(&ds),
- TCL_GLOBAL_ONLY);
- Tcl_DStringFree(&ds);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclpFindVariable --
- *
- * Locate the entry in environ for a given name. On Unix this
- * routine is case sensetive, 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(name, lengthPtr)
- 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 = (char *) ckalloc((unsigned) length+1);
- memcpy((VOID *) nameUpper, (VOID *) 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 = 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;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_Init --
- *
- * This procedure is typically invoked by Tcl_AppInit procedures
- * to perform additional initialization for a Tcl interpreter,
- * such as sourcing the "init.tcl" script.
- *
- * Results:
- * Returns a standard Tcl completion code and sets the interp's
- * result if there is an error.
- *
- * Side effects:
- * Depends on what's in the init.tcl script.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Tcl_Init(interp)
- Tcl_Interp *interp; /* Interpreter to initialize. */
-{
- Tcl_Obj *pathPtr;
-
- if (tclPreInitScript != NULL) {
- if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) {
- return (TCL_ERROR);
- };
- }
-
- pathPtr = TclGetLibraryPath();
- if (pathPtr == NULL) {
- pathPtr = Tcl_NewObj();
- }
- Tcl_SetVar2Ex(interp, "tcl_libPath", NULL, pathPtr, TCL_GLOBAL_ONLY);
- return Tcl_Eval(interp, initScript);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_SourceRCFile --
- *
- * This procedure is typically invoked by Tcl_Main of Tk_Main
- * procedure to source an application specific rc file into the
- * interpreter at startup time.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Depends on what's in the rc script.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_SourceRCFile(interp)
- Tcl_Interp *interp; /* Interpreter to source rc file into. */
-{
- Tcl_DString temp;
- char *fileName;
- Tcl_Channel errChannel;
-
- fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY);
-
- if (fileName != NULL) {
- Tcl_Channel c;
- char *fullName;
-
- Tcl_DStringInit(&temp);
- fullName = Tcl_TranslateFileName(interp, fileName, &temp);
- if (fullName == NULL) {
- /*
- * Couldn't translate the file name (e.g. it referred to a
- * bogus user or there was no HOME environment variable).
- * Just do nothing.
- */
- } else {
-
- /*
- * Test for the existence of the rc file before trying to read it.
- */
-
- c = Tcl_OpenFileChannel(NULL, fullName, "r", 0);
- if (c != (Tcl_Channel) NULL) {
- Tcl_Close(NULL, c);
- if (Tcl_EvalFile(interp, fullName) != TCL_OK) {
- errChannel = Tcl_GetStdChannel(TCL_STDERR);
- if (errChannel) {
- Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
- Tcl_WriteChars(errChannel, "\n", 1);
- }
- }
- }
- }
- Tcl_DStringFree(&temp);
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclpAsyncMark --
- *
- * Wake up the main thread from a signal handler.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Sends a message to the main thread.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclpAsyncMark(async)
- Tcl_AsyncHandler async; /* Token for handler. */
-{
- /*
- * Need a way to kick the Windows event loop and tell it to go look at
- * asynchronous events.
- */
-
- PostThreadMessage(mainThreadId, WM_USER, 0, 0);
-}
diff --git a/win/tclWinInt.h b/win/tclWinInt.h
deleted file mode 100644
index b744045..0000000
--- a/win/tclWinInt.h
+++ /dev/null
@@ -1,109 +0,0 @@
-/*
- * 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.
- *
- * RCS: @(#) $Id: tclWinInt.h,v 1.8 1999/08/03 18:07:15 redman Exp $
- */
-
-#ifndef _TCLWININT
-#define _TCLWININT
-
-#ifndef _TCLINT
-#include "tclInt.h"
-#endif
-#ifndef _TCLPORT
-#include "tclPort.h"
-#endif
-
-/*
- * The following specifies how much stack space TclpCheckStackSpace()
- * ensures is available. TclpCheckStackSpace() is called by Tcl_EvalObj()
- * to help avoid overflowing the stack in the case of infinite recursion.
- */
-
-#define TCL_WIN_STACK_THRESHOLD 0x2000
-
-#ifdef BUILD_tcl
-# undef TCL_STORAGE_CLASS
-# define TCL_STORAGE_CLASS DLLEXPORT
-#endif
-
-/*
- * Some versions of Borland C have a define for the OSVERSIONINFO for
- * Win32s and for NT, but not for Windows 95.
- */
-
-#ifndef VER_PLATFORM_WIN32_WINDOWS
-#define VER_PLATFORM_WIN32_WINDOWS 1
-#endif
-
-/*
- * The following structure keeps track of whether we are using the
- * multi-byte or the wide-character interfaces to the operating system.
- * System calls should be made through the following function table.
- */
-
-typedef union {
- WIN32_FIND_DATAA a;
- WIN32_FIND_DATAW w;
-} WIN32_FIND_DATAT;
-
-typedef struct TclWinProcs {
- int useWide;
-
- BOOL (WINAPI *buildCommDCBProc)(CONST TCHAR *, LPDCB);
- TCHAR *(WINAPI *charLowerProc)(TCHAR *);
- BOOL (WINAPI *copyFileProc)(CONST TCHAR *, CONST TCHAR *, BOOL);
- BOOL (WINAPI *createDirectoryProc)(CONST TCHAR *, LPSECURITY_ATTRIBUTES);
- HANDLE (WINAPI *createFileProc)(CONST TCHAR *, DWORD, DWORD,
- LPSECURITY_ATTRIBUTES, DWORD, DWORD, HANDLE);
- BOOL (WINAPI *createProcessProc)(CONST TCHAR *, TCHAR *,
- LPSECURITY_ATTRIBUTES, LPSECURITY_ATTRIBUTES, BOOL, DWORD,
- LPVOID, CONST TCHAR *, LPSTARTUPINFOA, LPPROCESS_INFORMATION);
- BOOL (WINAPI *deleteFileProc)(CONST TCHAR *);
- HANDLE (WINAPI *findFirstFileProc)(CONST TCHAR *, WIN32_FIND_DATAT *);
- BOOL (WINAPI *findNextFileProc)(HANDLE, WIN32_FIND_DATAT *);
- BOOL (WINAPI *getComputerNameProc)(WCHAR *, LPDWORD);
- DWORD (WINAPI *getCurrentDirectoryProc)(DWORD, WCHAR *);
- DWORD (WINAPI *getFileAttributesProc)(CONST TCHAR *);
- DWORD (WINAPI *getFullPathNameProc)(CONST TCHAR *, DWORD nBufferLength,
- WCHAR *, TCHAR **);
- DWORD (WINAPI *getModuleFileNameProc)(HMODULE, WCHAR *, int);
- DWORD (WINAPI *getShortPathNameProc)(CONST TCHAR *, WCHAR *, DWORD);
- UINT (WINAPI *getTempFileNameProc)(CONST TCHAR *, CONST TCHAR *, UINT,
- WCHAR *);
- DWORD (WINAPI *getTempPathProc)(DWORD, WCHAR *);
- BOOL (WINAPI *getVolumeInformationProc)(CONST TCHAR *, WCHAR *, DWORD,
- LPDWORD, LPDWORD, LPDWORD, WCHAR *, DWORD);
- HINSTANCE (WINAPI *loadLibraryProc)(CONST TCHAR *);
- TCHAR (WINAPI *lstrcpyProc)(WCHAR *, CONST TCHAR *);
- BOOL (WINAPI *moveFileProc)(CONST TCHAR *, CONST TCHAR *);
- BOOL (WINAPI *removeDirectoryProc)(CONST TCHAR *);
- DWORD (WINAPI *searchPathProc)(CONST TCHAR *, CONST TCHAR *,
- CONST TCHAR *, DWORD, WCHAR *, TCHAR **);
- BOOL (WINAPI *setCurrentDirectoryProc)(CONST TCHAR *);
- BOOL (WINAPI *setFileAttributesProc)(CONST TCHAR *, DWORD);
-} TclWinProcs;
-
-EXTERN TclWinProcs *tclWinProcs;
-EXTERN Tcl_Encoding tclWinTCharEncoding;
-
-/*
- * Declarations of functions that are not accessible by way of the
- * stubs table.
- */
-
-EXTERN void TclWinInit(HINSTANCE hInst);
-
-# undef TCL_STORAGE_CLASS
-# define TCL_STORAGE_CLASS DLLIMPORT
-
-#include "tclIntPlatDecls.h"
-
-#endif /* _TCLWININT */
diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c
deleted file mode 100644
index 360b629..0000000
--- a/win/tclWinLoad.c
+++ /dev/null
@@ -1,191 +0,0 @@
-/*
- * tclWinLoad.c --
- *
- * This procedure 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.
- *
- * RCS: @(#) $Id: tclWinLoad.c,v 1.5 2000/02/10 09:53:57 hobbs Exp $
- */
-
-#include "tclWinInt.h"
-
-
-/*
- *----------------------------------------------------------------------
- *
- * TclpLoadFile --
- *
- * Dynamically loads a binary code file into memory and returns
- * the addresses of two procedures within that file, if they
- * are defined.
- *
- * 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
-TclpLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
- Tcl_Interp *interp; /* Used for error reporting. */
- char *fileName; /* Name of the file containing the desired
- * code. */
- char *sym1, *sym2; /* Names of two procedures to look up in
- * the file's symbol table. */
- Tcl_PackageInitProc **proc1Ptr, **proc2Ptr;
- /* Where to return the addresses corresponding
- * to sym1 and sym2. */
- ClientData *clientDataPtr; /* Filled with token for dynamically loaded
- * file which will be passed back to
- * TclpUnloadFile() to unload the file. */
-{
- HINSTANCE handle;
- TCHAR *nativeName;
- Tcl_DString ds;
-
- nativeName = Tcl_WinUtfToTChar(fileName, -1, &ds);
- handle = (*tclWinProcs->loadLibraryProc)(nativeName);
- Tcl_DStringFree(&ds);
-
- *clientDataPtr = (ClientData) handle;
-
- if (handle == NULL) {
- DWORD lastError = GetLastError();
-#if 0
- /*
- * It would be ideal if the FormatMessage stuff worked better,
- * but unfortunately it doesn't seem to want to...
- */
- LPTSTR lpMsgBuf;
- char *buf;
- int size;
- size = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM |
- FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, lastError, 0,
- (LPTSTR) &lpMsgBuf, 0, NULL);
- buf = (char *) ckalloc((unsigned) TCL_INTEGER_SPACE + size + 1);
- sprintf(buf, "%d %s", lastError, (char *)lpMsgBuf);
-#endif
- Tcl_AppendResult(interp, "couldn't load library \"",
- fileName, "\": ", (char *) NULL);
- /*
- * 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
- */
- switch (lastError) {
- case ERROR_MOD_NOT_FOUND:
- case ERROR_DLL_NOT_FOUND:
- Tcl_AppendResult(interp, "this library or a dependent library",
- " could not be found in library path", (char *)
- NULL);
- break;
- case ERROR_INVALID_DLL:
- Tcl_AppendResult(interp, "this library or a dependent library",
- " is damaged", (char *) NULL);
- break;
- case ERROR_DLL_INIT_FAILED:
- Tcl_AppendResult(interp, "the library initialization",
- " routine failed", (char *) NULL);
- break;
- default:
- TclWinConvertError(lastError);
- Tcl_AppendResult(interp, Tcl_PosixError(interp),
- (char *) NULL);
- }
- return TCL_ERROR;
- }
-
- /*
- * For each symbol, check for both Symbol and _Symbol, since Borland
- * generates C symbols with a leading '_' by default.
- */
-
- *proc1Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, sym1);
- if (*proc1Ptr == NULL) {
- Tcl_DStringAppend(&ds, "_", 1);
- sym1 = Tcl_DStringAppend(&ds, sym1, -1);
- *proc1Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, sym1);
- Tcl_DStringFree(&ds);
- }
-
- *proc2Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, sym2);
- if (*proc2Ptr == NULL) {
- Tcl_DStringAppend(&ds, "_", 1);
- sym2 = Tcl_DStringAppend(&ds, sym2, -1);
- *proc2Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, sym2);
- Tcl_DStringFree(&ds);
- }
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclpUnloadFile --
- *
- * 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.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclpUnloadFile(clientData)
- ClientData clientData; /* ClientData returned by a previous call
- * to TclpLoadFile(). The clientData is
- * a token that represents the loaded
- * file. */
-{
- HINSTANCE handle;
-
- handle = (HINSTANCE) clientData;
- FreeLibrary(handle);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclGuessPackageName --
- *
- * If the "load" command is invoked without providing a package
- * name, this procedure 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(fileName, bufPtr)
- 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;
-}
diff --git a/win/tclWinMtherr.c b/win/tclWinMtherr.c
deleted file mode 100644
index 7be9b97..0000000
--- a/win/tclWinMtherr.c
+++ /dev/null
@@ -1,52 +0,0 @@
-/*
- * tclWinMtherr.c --
- *
- * This function provides a default implementation of the
- * _matherr function for Borland C++.
- *
- * Copyright (c) 1995 Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * RCS: @(#) $Id: tclWinMtherr.c,v 1.3 1999/04/16 00:48:09 stanton Exp $
- */
-
-#include "tclWinInt.h"
-#include <math.h>
-
-
-/*
- *----------------------------------------------------------------------
- *
- * _matherr --
- *
- * This procedure is invoked by Borland C++ when certain
- * errors occur in mathematical functions. This procedure
- * replaces the default implementation which generates pop-up
- * warnings.
- *
- * Results:
- * Returns 1 to indicate that we've handled the error
- * locally.
- *
- * Side effects:
- * Sets errno based on what's in xPtr.
- *
- *----------------------------------------------------------------------
- */
-
-int
-_matherr(xPtr)
- struct exception *xPtr; /* Describes error that occurred. */
-{
- if (!TclMathInProgress()) {
- return 0;
- }
- if ((xPtr->type == DOMAIN) || (xPtr->type == SING)) {
- errno = EDOM;
- } else {
- errno = ERANGE;
- }
- return 1;
-}
diff --git a/win/tclWinNotify.c b/win/tclWinNotify.c
deleted file mode 100644
index 932f86c..0000000
--- a/win/tclWinNotify.c
+++ /dev/null
@@ -1,514 +0,0 @@
-/*
- * 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.
- *
- * RCS: @(#) $Id: tclWinNotify.c,v 1.5 1999/07/02 22:08:28 redman Exp $
- */
-
-#include "tclWinInt.h"
-#include <winsock.h>
-
-/*
- * The follwing static indicates whether this module has been initialized.
- */
-
-static int initialized = 0;
-
-#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 ThreadSpecificData {
- 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;
-
-extern TclStubs tclStubs;
-/*
- * 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;
-TCL_DECLARE_MUTEX(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()
-{
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- WNDCLASS class;
-
- /*
- * Register Notifier window class if this is the first thread to
- * use this module.
- */
-
- Tcl_MutexLock(&notifierMutex);
- if (notifierCount == 0) {
- class.style = 0;
- class.cbClsExtra = 0;
- class.cbWndExtra = 0;
- class.hInstance = TclWinGetTclInstance();
- class.hbrBackground = NULL;
- class.lpszMenuName = NULL;
- class.lpszClassName = "TclNotifier";
- class.lpfnWndProc = NotifierProc;
- class.hIcon = NULL;
- class.hCursor = NULL;
-
- if (!RegisterClassA(&class)) {
- panic("Unable to register TclNotifier window class");
- }
- }
- notifierCount++;
- Tcl_MutexUnlock(&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 (ClientData) 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 clientData; /* Pointer to notifier data. */
-{
- ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;
-
- 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.
- */
-
- Tcl_MutexLock(&notifierMutex);
- notifierCount--;
- if (notifierCount == 0) {
- UnregisterClassA("TclNotifier", TclWinGetTclInstance());
- }
- Tcl_MutexUnlock(&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 clientData; /* Pointer to thread data. */
-{
- ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;
-
- /*
- * Note that we do not need to lock around access to the hwnd
- * because the race condition has no effect since any race condition
- * implies that the notifier thread is already awake.
- */
-
- if (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(
- Tcl_Time *timePtr) /* Maximum block time, or NULL. */
-{
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- UINT timeout;
-
- /*
- * Allow the notifier to be hooked. This may not make sense
- * on Windows, but mirrors the UNIX hook.
- */
-
- if (tclStubs.tcl_SetTimer != Tcl_SetTimer) {
- tclStubs.tcl_SetTimer(timePtr);
- return;
- }
-
- /*
- * We only need to set up an interval timer if we're being called
- * from an external event loop. If we don't have a window handle
- * then we just return immediately and let Tcl_WaitForEvent handle
- * timeouts.
- */
-
- if (!tsdPtr->hwnd) {
- 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(mode)
- int mode; /* Either TCL_SERVICE_ALL, or
- * TCL_SERVICE_NONE. */
-{
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
-
- /*
- * If this is the first time that the notifier has been used from a
- * modal loop, then create a communication window. Note that after
- * this point, the application needs to service events in a timely
- * fashion or Windows will hang waiting for the window to respond
- * to synchronous system messages. At some point, we may want to
- * consider destroying the window if we leave the modal loop, but
- * for now we'll leave it around.
- */
-
- if (mode == TCL_SERVICE_ALL && !tsdPtr->hwnd) {
- tsdPtr->hwnd = CreateWindowA("TclNotifier", "TclNotifier", WS_TILED,
- 0, 0, 0, 0, NULL, NULL, TclWinGetTclInstance(), NULL);
- /*
- * 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((ClientData)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,
- UINT message,
- WPARAM wParam,
- LPARAM lParam)
-{
- 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(
- Tcl_Time *timePtr) /* Maximum block time, or NULL. */
-{
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- MSG msg;
- DWORD timeout, result;
- int status;
-
- /*
- * Allow the notifier to be hooked. This may not make
- * sense on windows, but mirrors the UNIX hook.
- */
-
- if (tclStubs.tcl_WaitForEvent != Tcl_WaitForEvent) {
- return tclStubs.tcl_WaitForEvent(timePtr);
- }
-
- /*
- * Compute the timeout in milliseconds.
- */
-
- if (timePtr) {
- timeout = timePtr->sec * 1000 + timePtr->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).
- */
-
- result = MsgWaitForMultipleObjects(1, &tsdPtr->event, FALSE, timeout,
- QS_ALLINPUT);
- }
-
- /*
- * 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(msg.wParam);
- status = -1;
- } else if (result == -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;
- }
-
- ResetEvent(tsdPtr->event);
- return status;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_Sleep --
- *
- * Delay execution for the specified number of milliseconds.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Time passes.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_Sleep(ms)
- int ms; /* Number of milliseconds to sleep. */
-{
- Sleep(ms);
-}
diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c
deleted file mode 100644
index 0f3793a..0000000
--- a/win/tclWinPipe.c
+++ /dev/null
@@ -1,2825 +0,0 @@
-/*
- * 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.
- *
- * RCS: @(#) $Id: tclWinPipe.c,v 1.11.2.1 2000/07/27 01:39:25 hobbs Exp $
- */
-
-#include "tclWinInt.h"
-
-#include <dos.h>
-#include <fcntl.h>
-#include <io.h>
-#include <sys/stat.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 WinFile {
- 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. */
-
-/*
- * 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 startReader; /* Auto-reset event used by the main thread to
- * signal when the reader thread should attempt
- * to read from the pipe. */
- 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 ThreadSpecificData {
- /*
- * 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 PipeEvent {
- 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,
- 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 void PipeExitHandler(ClientData clientData);
-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, 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 void ProcExitHandler(ClientData clientData);
-static int TempFileName(WCHAR name[MAX_PATH]);
-static int WaitForRead(PipeInfo *infoPtr, int blocking);
-
-/*
- * This structure describes the channel type structure for command pipe
- * based IO.
- */
-
-static Tcl_ChannelType pipeChannelType = {
- "pipe", /* Type name. */
- TCL_CHANNEL_VERSION_2, /* v2 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. */
-};
-
-/*
- *----------------------------------------------------------------------
- *
- * PipeInit --
- *
- * This function initializes the static variables for this file.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Creates a new event source.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-PipeInit()
-{
- 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_CreateExitHandler(ProcExitHandler, NULL);
- }
- Tcl_MutexUnlock(&pipeMutex);
- }
-
- tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
- if (tsdPtr == NULL) {
- tsdPtr = TCL_TSD_INIT(&dataKey);
- tsdPtr->firstPipePtr = NULL;
- Tcl_CreateEventSource(PipeSetupProc, PipeCheckProc, NULL);
- Tcl_CreateThreadExitHandler(PipeExitHandler, NULL);
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * PipeExitHandler --
- *
- * This function is called to cleanup the pipe module before
- * Tcl is unloaded.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Removes the pipe event source.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-PipeExitHandler(
- ClientData clientData) /* Old window proc */
-{
- Tcl_DeleteEventSource(PipeSetupProc, PipeCheckProc, 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(&pipeMutex);
- initialized = 0;
- Tcl_MutexUnlock(&pipeMutex);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * PipeSetupProc --
- *
- * This procedure 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;
- WinFile *filePtr;
- 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) {
- filePtr = (WinFile*) infoPtr->writeFile;
- if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) {
- block = 0;
- }
- }
- if (infoPtr->watchMask & TCL_READABLE) {
- filePtr = (WinFile*) infoPtr->readFile;
- if (WaitForRead(infoPtr, 0) >= 0) {
- block = 0;
- }
- }
- }
- if (!block) {
- Tcl_SetMaxBlockTime(&blockTime);
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * PipeCheckProc --
- *
- * This procedure 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;
- WinFile *filePtr;
- 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;
- filePtr = (WinFile*) infoPtr->writeFile;
- if ((infoPtr->watchMask & TCL_WRITABLE) &&
- (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT)) {
- needEvent = 1;
- }
-
- filePtr = (WinFile*) infoPtr->readFile;
- if ((infoPtr->watchMask & TCL_READABLE) &&
- (WaitForRead(infoPtr, 0) >= 0)) {
- needEvent = 1;
- }
-
- if (needEvent) {
- infoPtr->flags |= PIPE_PENDING;
- evPtr = (PipeEvent *) 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 = (WinFile *) 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(name)
- WCHAR name[MAX_PATH]; /* Buffer in which name for temporary
- * file gets stored. */
-{
- TCHAR *prefix;
-
- prefix = (tclWinProcs->useWide) ? (TCHAR *) L"TCL" : (TCHAR *) "TCL";
- if ((*tclWinProcs->getTempPathProc)(MAX_PATH, name) != 0) {
- if ((*tclWinProcs->getTempFileNameProc)((TCHAR *) name, prefix, 0,
- name) != 0) {
- return 1;
- }
- }
- if (tclWinProcs->useWide) {
- ((WCHAR *) name)[0] = '.';
- ((WCHAR *) name)[1] = '\0';
- } else {
- ((char *) name)[0] = '.';
- ((char *) name)[1] = '\0';
- }
- return (*tclWinProcs->getTempFileNameProc)((TCHAR *) name, prefix, 0,
- name);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclpMakeFile --
- *
- * Make a TclFile from a channel.
- *
- * Results:
- * Returns a new TclFile or NULL on failure.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-TclFile
-TclpMakeFile(channel, direction)
- 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(path, mode)
- 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;
- 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 = (*tclWinProcs->getFileAttributesProc)(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 = (*tclWinProcs->createFileProc)(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) {
- 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(contents)
- CONST char *contents; /* String to write into temp file, or NULL. */
-{
- WCHAR name[MAX_PATH];
- CONST char *native;
- Tcl_DString dstring;
- HANDLE handle;
-
- if (TempFileName(name) == 0) {
- return NULL;
- }
-
- handle = (*tclWinProcs->createFileProc)((TCHAR *) name,
- GENERIC_READ | GENERIC_WRITE, 0, NULL, CREATE_ALWAYS,
- FILE_ATTRIBUTE_TEMPORARY|FILE_FLAG_DELETE_ON_CLOSE, NULL);
- if (handle == INVALID_HANDLE_VALUE) {
- goto error;
- }
-
- /*
- * Write the file out, doing line translations on the way.
- */
-
- if (contents != NULL) {
- DWORD result, length;
- CONST char *p;
-
- /*
- * Convert the contents from UTF to native encoding
- */
- native = Tcl_UtfToExternalDString(NULL, contents, -1, &dstring);
-
- for (p = native; *p != '\0'; p++) {
- 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);
- (*tclWinProcs->deleteFileProc)((TCHAR *) name);
- return NULL;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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 exit process. Otherwise, one thread may kill the
- * stdio of another.
- */
-
- if (!TclInExit()
- || ((GetStdHandle(STD_INPUT_HANDLE) != filePtr->handle)
- && (GetStdHandle(STD_OUTPUT_HANDLE) != filePtr->handle)
- && (GetStdHandle(STD_ERROR_HANDLE) != filePtr->handle))) {
- if (CloseHandle(filePtr->handle) == FALSE) {
- TclWinConvertError(GetLastError());
- ckfree((char *) filePtr);
- return -1;
- }
- }
- break;
-
- default:
- panic("TclpCloseFile: unexpected file type");
- }
-
- ckfree((char *) 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.
- *
- *--------------------------------------------------------------------------
- */
-
-unsigned long
-TclpGetPid(
- Tcl_Pid pid) /* The HANDLE of the child process. */
-{
- ProcInfo *infoPtr;
-
- 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 ".com", ".exe", and ".bat" 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. */
- 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 procedure is successful, pidPtr
- * is filled with the process id of the child
- * process. */
-{
- int result, applType, createFlags;
- Tcl_DString cmdLine; /* Complete command line (TCHAR). */
- STARTUPINFOA 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_AppendResult(interp, "couldn't duplicate input handle: ",
- Tcl_PosixError(interp), (char *) NULL);
- 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.
- */
-
- if ((TclWinGetPlatformId() == VER_PLATFORM_WIN32_WINDOWS)
- && (applType == APPL_DOS)) {
- if (CreatePipe(&h, &startInfo.hStdOutput, &secAtts, 0) != FALSE) {
- CloseHandle(h);
- }
- } else {
- startInfo.hStdOutput = CreateFileA("NUL:", GENERIC_WRITE, 0,
- &secAtts, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL);
- }
- } else {
- DuplicateHandle(hProcess, outputHandle, hProcess, &startInfo.hStdOutput,
- 0, TRUE, DUPLICATE_SAME_ACCESS);
- }
- if (startInfo.hStdOutput == INVALID_HANDLE_VALUE) {
- TclWinConvertError(GetLastError());
- Tcl_AppendResult(interp, "couldn't duplicate output handle: ",
- Tcl_PosixError(interp), (char *) NULL);
- goto end;
- }
-
- if (errorHandle == INVALID_HANDLE_VALUE) {
- /*
- * If handle was not set, errors should be sent to an infinitely
- * deep sink.
- */
-
- startInfo.hStdError = CreateFileA("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_AppendResult(interp, "couldn't duplicate error handle: ",
- Tcl_PosixError(interp), (char *) NULL);
- 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;
- Tcl_DStringAppend(&cmdLine, "cmd.exe /c ", -1);
- } else {
- createFlags = DETACHED_PROCESS;
- }
- } else {
- if (HasConsole()) {
- createFlags = 0;
- } else {
- createFlags = DETACHED_PROCESS;
- }
-
- if (applType == APPL_DOS) {
- /*
- * Under Windows 95, 16-bit DOS applications do not work well
- * with pipes:
- *
- * 1. EOF on a pipe between a detached 16-bit DOS application
- * and another application is not seen at the other
- * end of the pipe, so the listening process blocks forever on
- * reads. This inablity to detect EOF happens when either a
- * 16-bit app or the 32-bit app is the listener.
- *
- * 2. If a 16-bit DOS application (detached or not) blocks when
- * writing to a pipe, it will never wake up again, and it
- * eventually brings the whole system down around it.
- *
- * The 16-bit application is run as a normal process inside
- * of a hidden helper console app, and this helper may be run
- * as a detached process. If any of the stdio handles is
- * a pipe, the helper application accumulates information
- * into temp files and forwards it to or from the DOS
- * application as appropriate. This means that DOS apps
- * must receive EOF from a stdin pipe before they will actually
- * begin, and must finish generating stdout or stderr before
- * the data will be sent to the next stage of the pipe.
- *
- * The helper app should be located in the same directory as
- * the tcl dll.
- */
-
- if (createFlags != 0) {
- startInfo.wShowWindow = SW_HIDE;
- startInfo.dwFlags |= STARTF_USESHOWWINDOW;
- createFlags = CREATE_NEW_CONSOLE;
- }
- Tcl_DStringAppend(&cmdLine, "tclpip" STRINGIFY(TCL_MAJOR_VERSION)
- STRINGIFY(TCL_MINOR_VERSION) ".dll ", -1);
- }
- }
-
- /*
- * 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 ((*tclWinProcs->createProcessProc)(NULL,
- (TCHAR *) Tcl_DStringValue(&cmdLine), NULL, NULL, TRUE,
- createFlags, NULL, NULL, &startInfo, &procInfo) == 0) {
- TclWinConvertError(GetLastError());
- Tcl_AppendResult(interp, "couldn't execute \"", argv[0],
- "\": ", Tcl_PosixError(interp), (char *) NULL);
- 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()
-{
- 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 procedure 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(interp, originalName, fullName)
- 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;
- TCHAR *nativeName;
- WCHAR nativeFullPath[MAX_PATH];
- static char extensions[][5] = {"", ".com", ".exe", ".bat"};
-
- /* 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() procedure 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 = (*tclWinProcs->searchPathProc)(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 = (*tclWinProcs->getFileAttributesProc)((TCHAR *) nativeFullPath);
- if ((attr == 0xffffffff) || (attr & FILE_ATTRIBUTE_DIRECTORY)) {
- continue;
- }
- strcpy(fullName, Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds));
- Tcl_DStringFree(&ds);
-
- ext = strrchr(fullName, '.');
- if ((ext != NULL) && (stricmp(ext, ".bat") == 0)) {
- applType = APPL_DOS;
- break;
- }
-
- hFile = (*tclWinProcs->createFileProc)((TCHAR *) 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) && (strcmp(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_AppendResult(interp, "couldn't execute \"", originalName,
- "\": ", Tcl_PosixError(interp), (char *) NULL);
- 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.
- */
-
- (*tclWinProcs->getShortPathNameProc)((TCHAR *) nativeFullPath,
- nativeFullPath, MAX_PATH);
- strcpy(fullName, Tcl_WinTCharToUtf((TCHAR *) 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. */
- 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.
- */
-
- Tcl_DStringAppend(&ds, Tcl_DStringValue(linePtr), -1);
-
- for (i = 0; i < argc; i++) {
- if (i == 0) {
- arg = executable;
- } else {
- arg = argv[i];
- Tcl_DStringAppend(&ds, " ", 1);
- }
-
- quote = 0;
- if (argv[i][0] == '\0') {
- quote = 1;
- } else {
- for (start = argv[i]; *start != '\0'; start++) {
- if (isspace(*start)) { /* INTL: ISO space. */
- quote = 1;
- break;
- }
- }
- }
- if (quote) {
- Tcl_DStringAppend(&ds, "\"", 1);
- }
-
- start = arg;
- for (special = arg; ; ) {
- if ((*special == '\\') &&
- (special[1] == '\\' || special[1] == '"')) {
- Tcl_DStringAppend(&ds, start, special - start);
- start = special;
- while (1) {
- special++;
- if (*special == '"') {
- /*
- * N backslashes followed a quote -> insert
- * N * 2 + 1 backslashes then a quote.
- */
-
- Tcl_DStringAppend(&ds, start, special - start);
- break;
- }
- if (*special != '\\') {
- break;
- }
- }
- Tcl_DStringAppend(&ds, start, special - start);
- start = special;
- }
- if (*special == '"') {
- Tcl_DStringAppend(&ds, start, special - start);
- Tcl_DStringAppend(&ds, "\\\"", 2);
- start = special + 1;
- }
- if (*special == '\0') {
- break;
- }
- special++;
- }
- Tcl_DStringAppend(&ds, start, special - start);
- if (quote) {
- Tcl_DStringAppend(&ds, "\"", 1);
- }
- }
- 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];
- int channelId;
- DWORD id;
- PipeInfo *infoPtr = (PipeInfo *) ckalloc((unsigned) 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;
-
- /*
- * Use one of the fds associated with the channel as the
- * channel id.
- */
-
- if (readFile) {
- channelId = (int) ((WinFile*)readFile)->handle;
- } else if (writeFile) {
- channelId = (int) ((WinFile*)writeFile)->handle;
- } else if (errorFile) {
- channelId = (int) ((WinFile*)errorFile)->handle;
- } else {
- channelId = 0;
- }
-
- 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->readThread = CreateThread(NULL, 8000, PipeReaderThread,
- infoPtr, 0, &id);
- SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST);
- infoPtr->validMask |= TCL_READABLE;
- } else {
- infoPtr->readThread = 0;
- }
- if (writeFile != NULL) {
- /*
- * Start the background writeer thwrite.
- */
-
- infoPtr->writable = CreateEvent(NULL, TRUE, TRUE, NULL);
- infoPtr->startWriter = CreateEvent(NULL, FALSE, FALSE, NULL);
- infoPtr->writeThread = CreateThread(NULL, 8000, 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).
- */
-
- wsprintfA(channelName, "file%lx", infoPtr);
- infoPtr->channel = Tcl_CreateChannel(&pipeChannelType, channelName,
- (ClientData) 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((Tcl_Interp *) NULL, infoPtr->channel,
- "-translation", "auto");
- Tcl_SetChannelOption((Tcl_Interp *) NULL, infoPtr->channel,
- "-eofchar", "\032 {}");
- return infoPtr->channel;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- Tcl_ChannelType *chanTypePtr;
- int i;
- char buf[TCL_INTEGER_SPACE];
-
- /*
- * Punt if the channel is not a command channel.
- */
-
- chanTypePtr = Tcl_GetChannelType(chan);
- if (chanTypePtr != &pipeChannelType) {
- return;
- }
-
- pipePtr = (PipeInfo *) Tcl_GetChannelInstanceData(chan);
- for (i = 0; i < pipePtr->numPids; i++) {
- wsprintfA(buf, "%lu", TclpGetPid(pipePtr->pidPtr[i]));
- Tcl_AppendElement(interp, buf);
- Tcl_DetachPids(1, &(pipePtr->pidPtr[i]));
- }
- if (pipePtr->numPids > 0) {
- ckfree((char *) 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);
-
- errorCode = 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) {
- /*
- * Forcibly terminate the background thread. We cannot rely on the
- * thread to cleanly terminate itself because we have no way of
- * closing the pipe handle without blocking in the case where the
- * thread is in the middle of an I/O operation. 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);
- TerminateThread(pipePtr->readThread, 0);
-
- /*
- * Wait for the thread to terminate. This ensures that we are
- * completely cleaned up before we leave this function.
- */
-
- WaitForSingleObject(pipePtr->readThread, INFINITE);
- Tcl_MutexUnlock(&pipeMutex);
-
- CloseHandle(pipePtr->readThread);
- CloseHandle(pipePtr->readable);
- CloseHandle(pipePtr->startReader);
- 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)) {
- /*
- * 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 (pipePtr->writeThread) {
- WaitForSingleObject(pipePtr->writable, INFINITE);
-
- /*
- * Forcibly terminate the background thread. We cannot rely on the
- * thread to cleanly terminate itself because we have no way of
- * closing the pipe handle without blocking in the case where the
- * thread is in the middle of an I/O operation. 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);
- TerminateThread(pipePtr->writeThread, 0);
-
- /*
- * Wait for the thread to terminate. This ensures that we are
- * completely cleaned up before we leave this function.
- */
-
- WaitForSingleObject(pipePtr->writeThread, INFINITE);
- Tcl_MutexUnlock(&pipeMutex);
-
-
- CloseHandle(pipePtr->writeThread);
- CloseHandle(pipePtr->writable);
- CloseHandle(pipePtr->startWriter);
- 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;
- }
- }
-
- /*
- * Wrap the error file into a channel and give it to the cleanup
- * routine.
- */
-
- if (pipePtr->errorFile) {
- WinFile *filePtr;
-
- filePtr = (WinFile*)pipePtr->errorFile;
- errChan = Tcl_MakeFileChannel((ClientData) filePtr->handle,
- TCL_READABLE);
- ckfree((char *) filePtr);
- } else {
- errChan = NULL;
- }
-
- result = TclCleanupChildren(interp, pipePtr->numPids, pipePtr->pidPtr,
- errChan);
-
- if (pipePtr->numPids > 0) {
- ckfree((char *) pipePtr->pidPtr);
- }
-
- if (pipePtr->writeBuf != NULL) {
- ckfree(pipePtr->writeBuf);
- }
-
- ckfree((char*) 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. */
- 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 = EAGAIN;
- 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, 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 procedure 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;
- WinFile *filePtr;
- 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.
- */
-
- filePtr = (WinFile*) ((PipeInfo*)infoPtr)->writeFile;
- mask = 0;
- if ((infoPtr->watchMask & TCL_WRITABLE) &&
- (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT)) {
- mask = TCL_WRITABLE;
- }
-
- filePtr = (WinFile*) ((PipeInfo*)infoPtr)->readFile;
- 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, **prevPtrPtr;
- int flags;
- Tcl_Pid result;
- DWORD ret;
-
- PipeInit();
-
- /*
- * If no pid is specified, do nothing.
- */
-
- if (pid == 0) {
- *statPtr = 0;
- return 0;
- }
-
- /*
- * Find the process on the process list.
- */
-
- Tcl_MutexLock(&pipeMutex);
- prevPtrPtr = &procList;
- for (infoPtr = procList; infoPtr != NULL;
- prevPtrPtr = &infoPtr->nextPtr, infoPtr = infoPtr->nextPtr) {
- if (infoPtr->hProcess == (HANDLE) pid) {
- 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) {
- return 0;
- } else {
- result = 0;
- }
- } else if (ret != WAIT_FAILED) {
- GetExitCodeProcess(infoPtr->hProcess, (DWORD*)statPtr);
- *statPtr = ((*statPtr << 8) & 0xff00);
- result = pid;
- } else {
- errno = ECHILD;
- *statPtr = ECHILD;
- result = (Tcl_Pid) -1;
- }
-
- /*
- * Remove the process from the process list and close the process handle.
- */
-
- CloseHandle(infoPtr->hProcess);
- *prevPtrPtr = infoPtr->nextPtr;
- ckfree((char*)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(hProcess, id)
- HANDLE hProcess; /* Handle to process */
- DWORD id; /* Global process identifier */
-{
- ProcInfo *procPtr = (ProcInfo *) ckalloc(sizeof(ProcInfo));
- procPtr->hProcess = hProcess;
- procPtr->dwProcessId = id;
- Tcl_MutexLock(&pipeMutex);
- procPtr->nextPtr = procList;
- procList = procPtr;
- Tcl_MutexUnlock(&pipeMutex);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_PidObjCmd --
- *
- * This procedure 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;
- Tcl_ChannelType *chanTypePtr;
- PipeInfo *pipePtr;
- int i;
- Tcl_Obj *resultPtr;
- char buf[TCL_INTEGER_SPACE];
-
- if (objc > 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "?channelId?");
- return TCL_ERROR;
- }
- if (objc == 1) {
- resultPtr = Tcl_GetObjResult(interp);
- wsprintfA(buf, "%lu", (unsigned long) getpid());
- Tcl_SetStringObj(resultPtr, buf, -1);
- } else {
- chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL),
- 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_GetObjResult(interp);
- for (i = 0; i < pipePtr->numPids; i++) {
- wsprintfA(buf, "%lu", TclpGetPid(pipePtr->pidPtr[i]));
- Tcl_ListObjAppendElement(/*interp*/ NULL, resultPtr,
- Tcl_NewStringObj(buf, -1));
- }
- }
- 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 = EAGAIN;
- 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.
- *
- *----------------------------------------------------------------------
- */
-
-static DWORD WINAPI
-PipeReaderThread(LPVOID arg)
-{
- PipeInfo *infoPtr = (PipeInfo *)arg;
- HANDLE *handle = ((WinFile *) infoPtr->readFile)->handle;
- DWORD count, err;
- int done = 0;
-
- while (!done) {
- /*
- * Wait for the main thread to signal before attempting to wait.
- */
-
- WaitForSingleObject(infoPtr->startReader, INFINITE);
-
- /*
- * 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);
- 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;
-
- while (!done) {
- /*
- * Wait for the main thread to signal before attempting to write.
- */
-
- WaitForSingleObject(infoPtr->startWriter, INFINITE);
-
- 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);
- Tcl_ThreadAlert(infoPtr->threadId);
- Tcl_MutexUnlock(&pipeMutex);
- }
- return 0;
-}
-
diff --git a/win/tclWinPort.h b/win/tclWinPort.h
deleted file mode 100644
index a40681c..0000000
--- a/win/tclWinPort.h
+++ /dev/null
@@ -1,454 +0,0 @@
-/*
- * 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.
- *
- * RCS: @(#) $Id: tclWinPort.h,v 1.12 2000/03/31 08:52:31 hobbs Exp $
- */
-
-#ifndef _TCLWINPORT
-#define _TCLWINPORT
-
-#ifndef _TCLINT
-# include "tclInt.h"
-#endif
-
-#ifdef CHECK_UNICODE_CALLS
-
-#define _UNICODE
-#define UNICODE
-
-#define __TCHAR_DEFINED
-typedef float *_TCHAR;
-
-#define _TCHAR_DEFINED
-typedef float *TCHAR;
-
-#endif
-
-/*
- *---------------------------------------------------------------------------
- * The following sets of #includes and #ifdefs are required to get Tcl to
- * compile under the windows compilers.
- *---------------------------------------------------------------------------
- */
-
-#include <stdio.h>
-#include <stdlib.h>
-
-#include <direct.h>
-#include <errno.h>
-#include <fcntl.h>
-#include <float.h>
-#include <io.h>
-#include <malloc.h>
-#include <process.h>
-#include <signal.h>
-#include <string.h>
-
-/*
- * Need to block out these includes for building extensions with MetroWerks
- * compiler for Win32.
- */
-
-#ifndef __MWERKS__
-#include <sys/stat.h>
-#include <sys/timeb.h>
-#include <sys/utime.h>
-#endif
-
-#include <tchar.h>
-#include <time.h>
-#include <winsock2.h>
-
-#define WIN32_LEAN_AND_MEAN
-#include <windows.h>
-#undef WIN32_LEAN_AND_MEAN
-
-#ifdef BUILD_tcl
-# undef TCL_STORAGE_CLASS
-# define TCL_STORAGE_CLASS DLLEXPORT
-#endif
-
-/*
- * Define EINPROGRESS in terms of WSAEINPROGRESS.
- */
-
-#ifndef EINPROGRESS
-#define EINPROGRESS WSAEINPROGRESS
-#endif
-
-/*
- * If ENOTSUP is not defined, define it to a value that will never occur.
- */
-
-#ifndef ENOTSUP
-#define ENOTSUP -1030507
-#endif
-
-/*
- * The following defines redefine the Windows Socket errors as
- * BSD errors so Tcl_PosixError can do the right thing.
- */
-
-#ifndef EWOULDBLOCK
-#define EWOULDBLOCK EAGAIN
-#endif
-#ifndef EALREADY
-#define EALREADY 149 /* operation already in progress */
-#endif
-#ifndef ENOTSOCK
-#define ENOTSOCK 95 /* Socket operation on non-socket */
-#endif
-#ifndef EDESTADDRREQ
-#define EDESTADDRREQ 96 /* Destination address required */
-#endif
-#ifndef EMSGSIZE
-#define EMSGSIZE 97 /* Message too long */
-#endif
-#ifndef EPROTOTYPE
-#define EPROTOTYPE 98 /* Protocol wrong type for socket */
-#endif
-#ifndef ENOPROTOOPT
-#define ENOPROTOOPT 99 /* Protocol not available */
-#endif
-#ifndef EPROTONOSUPPORT
-#define EPROTONOSUPPORT 120 /* Protocol not supported */
-#endif
-#ifndef ESOCKTNOSUPPORT
-#define ESOCKTNOSUPPORT 121 /* Socket type not supported */
-#endif
-#ifndef EOPNOTSUPP
-#define EOPNOTSUPP 122 /* Operation not supported on socket */
-#endif
-#ifndef EPFNOSUPPORT
-#define EPFNOSUPPORT 123 /* Protocol family not supported */
-#endif
-#ifndef EAFNOSUPPORT
-#define EAFNOSUPPORT 124 /* Address family not supported */
-#endif
-#ifndef EADDRINUSE
-#define EADDRINUSE 125 /* Address already in use */
-#endif
-#ifndef EADDRNOTAVAIL
-#define EADDRNOTAVAIL 126 /* Can't assign requested address */
-#endif
-#ifndef ENETDOWN
-#define ENETDOWN 127 /* Network is down */
-#endif
-#ifndef ENETUNREACH
-#define ENETUNREACH 128 /* Network is unreachable */
-#endif
-#ifndef ENETRESET
-#define ENETRESET 129 /* Network dropped connection on reset */
-#endif
-#ifndef ECONNABORTED
-#define ECONNABORTED 130 /* Software caused connection abort */
-#endif
-#ifndef ECONNRESET
-#define ECONNRESET 131 /* Connection reset by peer */
-#endif
-#ifndef ENOBUFS
-#define ENOBUFS 132 /* No buffer space available */
-#endif
-#ifndef EISCONN
-#define EISCONN 133 /* Socket is already connected */
-#endif
-#ifndef ENOTCONN
-#define ENOTCONN 134 /* Socket is not connected */
-#endif
-#ifndef ESHUTDOWN
-#define ESHUTDOWN 143 /* Can't send after socket shutdown */
-#endif
-#ifndef ETOOMANYREFS
-#define ETOOMANYREFS 144 /* Too many references: can't splice */
-#endif
-#ifndef ETIMEDOUT
-#define ETIMEDOUT 145 /* Connection timed out */
-#endif
-#ifndef ECONNREFUSED
-#define ECONNREFUSED 146 /* Connection refused */
-#endif
-#ifndef ELOOP
-#define ELOOP 90 /* Symbolic link loop */
-#endif
-#ifndef EHOSTDOWN
-#define EHOSTDOWN 147 /* Host is down */
-#endif
-#ifndef EHOSTUNREACH
-#define EHOSTUNREACH 148 /* No route to host */
-#endif
-#ifndef ENOTEMPTY
-#define ENOTEMPTY 93 /* directory not empty */
-#endif
-#ifndef EUSERS
-#define EUSERS 94 /* Too many users (for UFS) */
-#endif
-#ifndef EDQUOT
-#define EDQUOT 49 /* Disc quota exceeded */
-#endif
-#ifndef ESTALE
-#define ESTALE 151 /* Stale NFS file handle */
-#endif
-#ifndef EREMOTE
-#define EREMOTE 66 /* The object is remote */
-#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
-
-#ifndef WIFEXITED
-# define WIFEXITED(stat) (((*((int *) &(stat))) & 0xff) == 0)
-#endif
-
-#ifndef WEXITSTATUS
-# define WEXITSTATUS(stat) (((*((int *) &(stat))) >> 8) & 0xff)
-#endif
-
-#ifndef WIFSIGNALED
-# define WIFSIGNALED(stat) (((*((int *) &(stat)))) && ((*((int *) &(stat))) == ((*((int *) &(stat))) & 0x00ff)))
-#endif
-
-#ifndef WTERMSIG
-# define WTERMSIG(stat) ((*((int *) &(stat))) & 0x7f)
-#endif
-
-#ifndef WIFSTOPPED
-# define WIFSTOPPED(stat) (((*((int *) &(stat))) & 0xff) == 0177)
-#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_ISREG
-# ifdef S_IFREG
-# define S_ISREG(m) (((m) & S_IFMT) == S_IFREG)
-# else
-# define S_ISREG(m) 0
-# endif
-# endif
-#ifndef S_ISDIR
-# ifdef S_IFDIR
-# define S_ISDIR(m) (((m) & S_IFMT) == S_IFDIR)
-# else
-# define S_ISDIR(m) 0
-# endif
-# endif
-#ifndef S_ISCHR
-# ifdef S_IFCHR
-# define S_ISCHR(m) (((m) & S_IFMT) == S_IFCHR)
-# else
-# define S_ISCHR(m) 0
-# endif
-# endif
-#ifndef S_ISBLK
-# ifdef S_IFBLK
-# define S_ISBLK(m) (((m) & S_IFMT) == S_IFBLK)
-# else
-# define S_ISBLK(m) 0
-# endif
-# endif
-#ifndef S_ISFIFO
-# ifdef S_IFIFO
-# define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO)
-# else
-# define S_ISFIFO(m) 0
-# endif
-# endif
-
-/*
- * 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
-#if ! TCL_UID_T
-# define uid_t int
-#endif
-
-/*
- * 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(__MINGW32__)
-# define environ _environ
-# define hypot _hypot
-# define exception _exception
-# undef EDEADLOCK
-# if defined(__MINGW32__) && !defined(__MSVCRT__)
-# define timezone _timezone
-# endif
-#endif /* _MSC_VER || __MINGW32__ */
-
-/*
- *---------------------------------------------------------------------------
- * 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
-
-/*
- * 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))
-
-/*
- * The following defines map from standard socket names to our internal
- * wrappers that redirect through the winSock function table (see the
- * file tclWinSock.c).
- */
-
-#define getservbyname TclWinGetServByName
-#define getsockopt TclWinGetSockOpt
-#define ntohs TclWinNToHS
-#define setsockopt TclWinSetSockOpt
-
-/*
- * The following macros have trivial definitions, allowing generic code to
- * address platform-specific issues.
- */
-
-#define TclpReleaseFile(file) ckfree((char *) file)
-
-/*
- * The following macros and declarations wrap the C runtime library
- * functions.
- */
-
-#define TclpExit exit
-#define TclpLstat TclpStat
-
-/*
- * Declarations for Windows-only functions.
- */
-
-EXTERN Tcl_Channel TclWinOpenSerialChannel _ANSI_ARGS_((HANDLE handle,
- char *channelName, int permissions));
-
-EXTERN Tcl_Channel TclWinOpenConsoleChannel _ANSI_ARGS_((HANDLE handle,
- char *channelName, int permissions));
-
-EXTERN Tcl_Channel TclWinOpenFileChannel _ANSI_ARGS_((HANDLE handle,
- char *channelName, int permissions, int appendMode));
-
-EXTERN TclFile TclWinMakeFile _ANSI_ARGS_((HANDLE handle));
-
-/*
- * Platform specific mutex definition used by memory allocators.
- * These mutexes are statically allocated and explicitly initialized.
- * Most modules do not use this, but instead use Tcl_Mutex types and
- * Tcl_MutexLock and Tcl_MutexUnlock that are self-initializing.
- */
-
-#ifdef TCL_THREADS
-typedef CRITICAL_SECTION TclpMutex;
-EXTERN void TclpMutexInit _ANSI_ARGS_((TclpMutex *mPtr));
-EXTERN void TclpMutexLock _ANSI_ARGS_((TclpMutex *mPtr));
-EXTERN void TclpMutexUnlock _ANSI_ARGS_((TclpMutex *mPtr));
-#else
-typedef int TclpMutex;
-#define TclpMutexInit(a)
-#define TclpMutexLock(a)
-#define TclpMutexUnlock(a)
-#endif /* TCL_THREADS */
-
-#include "tclPlatDecls.h"
-#include "tclIntPlatDecls.h"
-
-# undef TCL_STORAGE_CLASS
-# define TCL_STORAGE_CLASS DLLIMPORT
-
-#endif /* _TCLWINPORT */
diff --git a/win/tclWinReg.c b/win/tclWinReg.c
deleted file mode 100644
index e5808c2..0000000
--- a/win/tclWinReg.c
+++ /dev/null
@@ -1,1414 +0,0 @@
-/*
- * 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.
- *
- * RCS: @(#) $Id: tclWinReg.c,v 1.11 2000/03/31 08:52:32 hobbs Exp $
- */
-
-#include <tclPort.h>
-#include <stdlib.h>
-
-#define WIN32_LEAN_AND_MEAN
-#include <windows.h>
-#undef WIN32_LEAN_AND_MEAN
-
-/*
- * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
- * Registry_Init declaration is in the source file itself, which is only
- * accessed when we are building a library.
- */
-
-#undef TCL_STORAGE_CLASS
-#define TCL_STORAGE_CLASS DLLEXPORT
-
-/*
- * The following macros convert between different endian ints.
- */
-
-#define SWAPWORD(x) MAKEWORD(HIBYTE(x), LOBYTE(x))
-#define SWAPLONG(x) MAKELONG(SWAPWORD(HIWORD(x)), SWAPWORD(LOWORD(x)))
-
-/*
- * 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 char *rootKeyNames[] = {
- "HKEY_LOCAL_MACHINE", "HKEY_USERS", "HKEY_CLASSES_ROOT",
- "HKEY_CURRENT_USER", "HKEY_CURRENT_CONFIG",
- "HKEY_PERFORMANCE_DATA", "HKEY_DYN_DATA", NULL
-};
-
-static HKEY rootKeys[] = {
- HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_CLASSES_ROOT, HKEY_CURRENT_USER,
- HKEY_CURRENT_CONFIG, HKEY_PERFORMANCE_DATA, HKEY_DYN_DATA
-};
-
-/*
- * 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 char *typeNames[] = {
- "none", "sz", "expand_sz", "binary", "dword",
- "dword_big_endian", "link", "multi_sz", "resource_list", NULL
-};
-
-static DWORD lastType = REG_RESOURCE_LIST;
-
-/*
- * The following structures allow us to select between the Unicode and ASCII
- * interfaces at run time based on whether Unicode APIs are available. The
- * Unicode APIs are preferable because they will handle characters outside
- * of the current code page.
- */
-
-typedef struct RegWinProcs {
- int useWide;
-
- LONG (WINAPI *regConnectRegistryProc)(TCHAR *, HKEY, PHKEY);
- LONG (WINAPI *regCreateKeyExProc)(HKEY, CONST TCHAR *, DWORD, TCHAR *,
- DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, DWORD *);
- LONG (WINAPI *regDeleteKeyProc)(HKEY, CONST TCHAR *);
- LONG (WINAPI *regDeleteValueProc)(HKEY, CONST TCHAR *);
- LONG (WINAPI *regEnumKeyProc)(HKEY, DWORD, TCHAR *, DWORD);
- LONG (WINAPI *regEnumKeyExProc)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
- TCHAR *, DWORD *, FILETIME *);
- LONG (WINAPI *regEnumValueProc)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
- DWORD *, BYTE *, DWORD *);
- LONG (WINAPI *regOpenKeyExProc)(HKEY, CONST TCHAR *, DWORD, REGSAM,
- HKEY *);
- LONG (WINAPI *regQueryInfoKeyProc)(HKEY, TCHAR *, DWORD *, DWORD *,
- DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *,
- FILETIME *);
- LONG (WINAPI *regQueryValueExProc)(HKEY, CONST TCHAR *, DWORD *, DWORD *,
- BYTE *, DWORD *);
- LONG (WINAPI *regSetValueExProc)(HKEY, CONST TCHAR *, DWORD, DWORD,
- CONST BYTE*, DWORD);
-} RegWinProcs;
-
-static RegWinProcs *regWinProcs;
-
-static RegWinProcs asciiProcs = {
- 0,
-
- (LONG (WINAPI *)(TCHAR *, HKEY, PHKEY)) RegConnectRegistryA,
- (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *,
- DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *,
- DWORD *)) RegCreateKeyExA,
- (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyA,
- (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueA,
- (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyA,
- (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
- TCHAR *, DWORD *, FILETIME *)) RegEnumKeyExA,
- (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
- DWORD *, BYTE *, DWORD *)) RegEnumValueA,
- (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, REGSAM,
- HKEY *)) RegOpenKeyExA,
- (LONG (WINAPI *)(HKEY, TCHAR *, DWORD *, DWORD *,
- DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *,
- FILETIME *)) RegQueryInfoKeyA,
- (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD *, DWORD *,
- BYTE *, DWORD *)) RegQueryValueExA,
- (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, DWORD,
- CONST BYTE*, DWORD)) RegSetValueExA,
-};
-
-static RegWinProcs unicodeProcs = {
- 1,
-
- (LONG (WINAPI *)(TCHAR *, HKEY, PHKEY)) RegConnectRegistryW,
- (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *,
- DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *,
- DWORD *)) RegCreateKeyExW,
- (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyW,
- (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueW,
- (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyW,
- (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
- TCHAR *, DWORD *, FILETIME *)) RegEnumKeyExW,
- (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
- DWORD *, BYTE *, DWORD *)) RegEnumValueW,
- (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, REGSAM,
- HKEY *)) RegOpenKeyExW,
- (LONG (WINAPI *)(HKEY, TCHAR *, DWORD *, DWORD *,
- DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *,
- FILETIME *)) RegQueryInfoKeyW,
- (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD *, DWORD *,
- BYTE *, DWORD *)) RegQueryValueExW,
- (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, DWORD,
- CONST BYTE*, DWORD)) RegSetValueExW,
-};
-
-
-/*
- * Declarations for functions defined in this file.
- */
-
-static void AppendSystemError(Tcl_Interp *interp, DWORD error);
-static DWORD ConvertDWORD(DWORD type, DWORD value);
-static int DeleteKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj);
-static int DeleteValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
- Tcl_Obj *valueNameObj);
-static int GetKeyNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
- Tcl_Obj *patternObj);
-static int GetType(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
- Tcl_Obj *valueNameObj);
-static int GetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
- Tcl_Obj *valueNameObj);
-static int GetValueNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
- Tcl_Obj *patternObj);
-static int OpenKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
- REGSAM mode, int flags, HKEY *keyPtr);
-static DWORD OpenSubKey(char *hostName, HKEY rootKey,
- 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, TCHAR * pKeyName);
-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);
-
-EXTERN int Registry_Init(Tcl_Interp *interp);
-
-/*
- *----------------------------------------------------------------------
- *
- * Registry_Init --
- *
- * This procedure initializes the registry command.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-Registry_Init(
- Tcl_Interp *interp)
-{
- if (!Tcl_InitStubs(interp, "8.0", 0)) {
- return TCL_ERROR;
- }
-
- /*
- * Determine if the unicode interfaces are available and select the
- * appropriate registry function table.
- */
-
- if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_NT) {
- regWinProcs = &unicodeProcs;
- } else {
- regWinProcs = &asciiProcs;
- }
-
- Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd, NULL, NULL);
- return Tcl_PkgProvide(interp, "registry", "1.0");
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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 index;
- char *errString;
-
- static char *subcommands[] = { "delete", "get", "keys", "set", "type",
- "values", (char *) NULL };
- enum SubCmdIdx { DeleteIdx, GetIdx, KeysIdx, SetIdx, TypeIdx, ValuesIdx };
-
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, objc, objv, "option ?arg arg ...?");
- return TCL_ERROR;
- }
-
- if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "option", 0, &index)
- != TCL_OK) {
- return TCL_ERROR;
- }
-
- switch (index) {
- case DeleteIdx: /* delete */
- if (objc == 3) {
- return DeleteKey(interp, objv[2]);
- } else if (objc == 4) {
- return DeleteValue(interp, objv[2], objv[3]);
- }
- errString = "keyName ?valueName?";
- break;
- case GetIdx: /* get */
- if (objc == 4) {
- return GetValue(interp, objv[2], objv[3]);
- }
- errString = "keyName valueName";
- break;
- case KeysIdx: /* keys */
- if (objc == 3) {
- return GetKeyNames(interp, objv[2], NULL);
- } else if (objc == 4) {
- return GetKeyNames(interp, objv[2], objv[3]);
- }
- errString = "keyName ?pattern?";
- break;
- case SetIdx: /* set */
- if (objc == 3) {
- HKEY key;
-
- /*
- * Create the key and then close it immediately.
- */
-
- if (OpenKey(interp, objv[2], KEY_ALL_ACCESS, 1, &key)
- != TCL_OK) {
- return TCL_ERROR;
- }
- RegCloseKey(key);
- return TCL_OK;
- } else if (objc == 5 || objc == 6) {
- Tcl_Obj *typeObj = (objc == 5) ? NULL : objv[5];
- return SetValue(interp, objv[2], objv[3], objv[4], typeObj);
- }
- errString = "keyName ?valueName data ?type??";
- break;
- case TypeIdx: /* type */
- if (objc == 4) {
- return GetType(interp, objv[2], objv[3]);
- }
- errString = "keyName valueName";
- break;
- case ValuesIdx: /* values */
- if (objc == 3) {
- return GetValueNames(interp, objv[2], NULL);
- } else if (objc == 4) {
- return GetValueNames(interp, objv[2], objv[3]);
- }
- errString = "keyName ?pattern?";
- break;
- }
- Tcl_WrongNumArgs(interp, 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. */
-{
- char *tail, *buffer, *hostName, *keyName;
- HKEY rootKey, subkey;
- DWORD result;
- int length;
- Tcl_Obj *resultPtr;
- Tcl_DString buf;
-
- /*
- * Find the parent of the key being deleted and open it.
- */
-
- keyName = Tcl_GetStringFromObj(keyNameObj, &length);
- buffer = ckalloc(length + 1);
- strcpy(buffer, keyName);
-
- if (ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName)
- != TCL_OK) {
- ckfree(buffer);
- return TCL_ERROR;
- }
-
- resultPtr = Tcl_GetObjResult(interp);
- if (*keyName == '\0') {
- Tcl_AppendToObj(resultPtr, "bad key: cannot delete root keys", -1);
- ckfree(buffer);
- return TCL_ERROR;
- }
-
- tail = strrchr(keyName, '\\');
- if (tail) {
- *tail++ = '\0';
- } else {
- tail = keyName;
- keyName = NULL;
- }
-
- result = OpenSubKey(hostName, rootKey, keyName,
- KEY_ENUMERATE_SUB_KEYS | DELETE, 0, &subkey);
- if (result != ERROR_SUCCESS) {
- ckfree(buffer);
- if (result == ERROR_FILE_NOT_FOUND) {
- return TCL_OK;
- } else {
- Tcl_AppendToObj(resultPtr, "unable to delete key: ", -1);
- AppendSystemError(interp, result);
- return TCL_ERROR;
- }
- }
-
- /*
- * Now we recursively delete the key and everything below it.
- */
-
- tail = Tcl_WinUtfToTChar(tail, -1, &buf);
- result = RecursiveDeleteKey(subkey, tail);
- Tcl_DStringFree(&buf);
-
- if (result != ERROR_SUCCESS && result != ERROR_FILE_NOT_FOUND) {
- Tcl_AppendToObj(resultPtr, "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. */
-{
- HKEY key;
- char *valueName;
- int length;
- DWORD result;
- Tcl_Obj *resultPtr;
- Tcl_DString ds;
-
- /*
- * Attempt to open the key for deletion.
- */
-
- if (OpenKey(interp, keyNameObj, KEY_SET_VALUE, 0, &key)
- != TCL_OK) {
- return TCL_ERROR;
- }
-
- resultPtr = Tcl_GetObjResult(interp);
- valueName = Tcl_GetStringFromObj(valueNameObj, &length);
- Tcl_WinUtfToTChar(valueName, length, &ds);
- result = (*regWinProcs->regDeleteValueProc)(key, Tcl_DStringValue(&ds));
- Tcl_DStringFree(&ds);
- if (result != ERROR_SUCCESS) {
- Tcl_AppendStringsToObj(resultPtr, "unable to delete value \"",
- Tcl_GetString(valueNameObj), "\" from key \"",
- Tcl_GetString(keyNameObj), "\": ", NULL);
- 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. */
-{
- HKEY key;
- DWORD index;
- char buffer[MAX_PATH+1], *pattern, *name;
- Tcl_Obj *resultPtr;
- int result = TCL_OK;
- Tcl_DString ds;
-
- /*
- * Attempt to open the key for enumeration.
- */
-
- if (OpenKey(interp, keyNameObj, KEY_ENUMERATE_SUB_KEYS, 0, &key)
- != TCL_OK) {
- return TCL_ERROR;
- }
-
- if (patternObj) {
- pattern = Tcl_GetString(patternObj);
- } else {
- pattern = NULL;
- }
-
- /*
- * Enumerate over the subkeys until we get an error, indicating the
- * end of the list.
- */
-
- resultPtr = Tcl_GetObjResult(interp);
- for (index = 0; (*regWinProcs->regEnumKeyProc)(key, index, buffer,
- MAX_PATH+1) == ERROR_SUCCESS; index++) {
- Tcl_WinTCharToUtf((TCHAR *) buffer, -1, &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;
- }
- }
-
- 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. */
-{
- HKEY key;
- Tcl_Obj *resultPtr;
- DWORD result;
- DWORD type;
- Tcl_DString ds;
- char *valueName;
- int length;
-
- /*
- * Attempt to open the key for reading.
- */
-
- if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key)
- != TCL_OK) {
- return TCL_ERROR;
- }
-
- /*
- * Get the type of the value.
- */
-
- resultPtr = Tcl_GetObjResult(interp);
-
- valueName = Tcl_GetStringFromObj(valueNameObj, &length);
- valueName = Tcl_WinUtfToTChar(valueName, length, &ds);
- result = (*regWinProcs->regQueryValueExProc)(key, valueName, NULL, &type,
- NULL, NULL);
- Tcl_DStringFree(&ds);
- RegCloseKey(key);
-
- if (result != ERROR_SUCCESS) {
- Tcl_AppendStringsToObj(resultPtr, "unable to get type of value \"",
- Tcl_GetString(valueNameObj), "\" from key \"",
- Tcl_GetString(keyNameObj), "\": ", NULL);
- 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 || type < 0) {
- Tcl_SetIntObj(resultPtr, type);
- } else {
- Tcl_SetStringObj(resultPtr, 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. */
-{
- HKEY key;
- char *valueName;
- DWORD result, length, type;
- Tcl_Obj *resultPtr;
- Tcl_DString data, buf;
- int nameLen;
-
- /*
- * Attempt to open the key for reading.
- */
-
- if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 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);
- length = TCL_DSTRING_STATIC_SIZE - 1;
- Tcl_DStringSetLength(&data, length);
-
- resultPtr = Tcl_GetObjResult(interp);
-
- valueName = Tcl_GetStringFromObj(valueNameObj, &nameLen);
- valueName = Tcl_WinUtfToTChar(valueName, nameLen, &buf);
-
- result = (*regWinProcs->regQueryValueExProc)(key, valueName, 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 *= 2;
- Tcl_DStringSetLength(&data, length);
- result = (*regWinProcs->regQueryValueExProc)(key, valueName, NULL,
- &type, (BYTE *) Tcl_DStringValue(&data), &length);
- }
- Tcl_DStringFree(&buf);
- RegCloseKey(key);
- if (result != ERROR_SUCCESS) {
- Tcl_AppendStringsToObj(resultPtr, "unable to get value \"",
- Tcl_GetString(valueNameObj), "\" from key \"",
- Tcl_GetString(keyNameObj), "\": ", NULL);
- 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_SetIntObj(resultPtr, ConvertDWORD(type,
- *((DWORD*) Tcl_DStringValue(&data))));
- } else if (type == REG_MULTI_SZ) {
- char *p = Tcl_DStringValue(&data);
- char *end = Tcl_DStringValue(&data) + length;
-
- /*
- * 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 && ((regWinProcs->useWide)
- ? *((Tcl_UniChar *)p) : *p) != 0) {
- Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf);
- Tcl_ListObjAppendElement(interp, resultPtr,
- Tcl_NewStringObj(Tcl_DStringValue(&buf),
- Tcl_DStringLength(&buf)));
- if (regWinProcs->useWide) {
- while (*((Tcl_UniChar *)p)++ != 0) {}
- } else {
- while (*p++ != '\0') {}
- }
- Tcl_DStringFree(&buf);
- }
- } else if ((type == REG_SZ) || (type == REG_EXPAND_SZ)) {
- Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&data), -1, &buf);
- Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&buf),
- Tcl_DStringLength(&buf));
- Tcl_DStringFree(&buf);
- } else {
- /*
- * Save binary data as a byte array.
- */
-
- Tcl_SetByteArrayObj(resultPtr, Tcl_DStringValue(&data), 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. */
-{
- HKEY key;
- Tcl_Obj *resultPtr;
- DWORD index, size, maxSize, result;
- Tcl_DString buffer, ds;
- char *pattern, *name;
-
- /*
- * Attempt to open the key for enumeration.
- */
-
- if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key)
- != TCL_OK) {
- return TCL_ERROR;
- }
-
- resultPtr = Tcl_GetObjResult(interp);
-
- /*
- * Query the key to determine the appropriate buffer size to hold the
- * largest value name plus the terminating null.
- */
-
- result = (*regWinProcs->regQueryInfoKeyProc)(key, NULL, NULL, NULL, NULL,
- NULL, NULL, &index, &maxSize, NULL, NULL, NULL);
- if (result != ERROR_SUCCESS) {
- Tcl_AppendStringsToObj(resultPtr, "unable to query key \"",
- Tcl_GetString(keyNameObj), "\": ", NULL);
- AppendSystemError(interp, result);
- RegCloseKey(key);
- result = TCL_ERROR;
- goto done;
- }
- maxSize++;
-
-
- Tcl_DStringInit(&buffer);
- Tcl_DStringSetLength(&buffer,
- (regWinProcs->useWide) ? maxSize*2 : maxSize);
- 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 = maxSize;
- while ((*regWinProcs->regEnumValueProc)(key, index,
- Tcl_DStringValue(&buffer), &size, NULL, NULL, NULL, NULL)
- == ERROR_SUCCESS) {
-
- if (regWinProcs->useWide) {
- size *= 2;
- }
-
- Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&buffer), 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 = maxSize;
- }
- Tcl_DStringFree(&buffer);
-
- done:
- 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;
- int length;
- HKEY rootKey;
- DWORD result;
-
- keyName = Tcl_GetStringFromObj(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_Obj *resultPtr = Tcl_GetObjResult(interp);
- Tcl_AppendToObj(resultPtr, "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 = Tcl_WinUtfToTChar(hostName, -1, &buf);
- result = (*regWinProcs->regConnectRegistryProc)(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 = Tcl_WinUtfToTChar(keyName, -1, &buf);
- if (flags & REG_CREATE) {
- DWORD create;
- result = (*regWinProcs->regCreateKeyExProc)(rootKey, keyName, 0, "",
- 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 = (*regWinProcs->regOpenKeyExProc)(rootKey, 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, *resultPtr = Tcl_GetObjResult(interp);
-
- /*
- * 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_AppendStringsToObj(resultPtr, "bad key \"", name,
- "\": must start with a valid root", 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. */
- char *keyName) /* Name of key to be deleted in external
- * encoding, not UTF. */
-{
- DWORD result, size, maxSize;
- Tcl_DString subkey;
- HKEY hKey;
-
- /*
- * Do not allow NULL or empty key name.
- */
-
- if (!keyName || *keyName == '\0') {
- return ERROR_BADKEY;
- }
-
- result = (*regWinProcs->regOpenKeyExProc)(startKey, keyName, 0,
- KEY_ENUMERATE_SUB_KEYS | DELETE | KEY_QUERY_VALUE, &hKey);
- if (result != ERROR_SUCCESS) {
- return result;
- }
- result = (*regWinProcs->regQueryInfoKeyProc)(hKey, NULL, NULL, NULL, NULL,
- &maxSize, NULL, NULL, NULL, NULL, NULL, NULL);
- maxSize++;
- if (result != ERROR_SUCCESS) {
- return result;
- }
-
- Tcl_DStringInit(&subkey);
- Tcl_DStringSetLength(&subkey,
- (regWinProcs->useWide) ? maxSize * 2 : maxSize);
-
- while (result == ERROR_SUCCESS) {
- /*
- * Always get index 0 because key deletion changes ordering.
- */
-
- size = maxSize;
- result=(*regWinProcs->regEnumKeyExProc)(hKey, 0,
- Tcl_DStringValue(&subkey), &size, NULL, NULL, NULL, NULL);
- if (result == ERROR_NO_MORE_ITEMS) {
- result = (*regWinProcs->regDeleteKeyProc)(startKey, keyName);
- break;
- } else if (result == ERROR_SUCCESS) {
- result = RecursiveDeleteKey(hKey, Tcl_DStringValue(&subkey));
- }
- }
- 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. */
-{
- DWORD type, result;
- HKEY key;
- int length;
- char *valueName;
- Tcl_Obj *resultPtr;
- 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);
- }
- if (OpenKey(interp, keyNameObj, KEY_ALL_ACCESS, 1, &key) != TCL_OK) {
- return TCL_ERROR;
- }
-
- valueName = Tcl_GetStringFromObj(valueNameObj, &length);
- valueName = Tcl_WinUtfToTChar(valueName, length, &nameBuf);
- resultPtr = Tcl_GetObjResult(interp);
-
- if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) {
- DWORD value;
- if (Tcl_GetIntFromObj(interp, dataObj, (int*) &value) != TCL_OK) {
- RegCloseKey(key);
- Tcl_DStringFree(&nameBuf);
- return TCL_ERROR;
- }
-
- value = ConvertDWORD(type, value);
- result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, 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++) {
- Tcl_DStringAppend(&data, Tcl_GetString(objv[i]), -1);
-
- /*
- * Add a null character to separate this value from the next.
- * We accomplish this by growing the string by one byte. Since the
- * DString always tacks on an extra null byte, the new byte will
- * already be set to null.
- */
-
- Tcl_DStringSetLength(&data, Tcl_DStringLength(&data)+1);
- }
-
- Tcl_WinUtfToTChar(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1,
- &buf);
- result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, 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;
- char *data = Tcl_GetStringFromObj(dataObj, &length);
-
- data = Tcl_WinUtfToTChar(data, length, &buf);
-
- /*
- * Include the null in the length, padding if needed for Unicode.
- */
-
- if (regWinProcs->useWide) {
- Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1);
- }
- length = Tcl_DStringLength(&buf) + 1;
-
- result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type,
- (BYTE*)data, length);
- Tcl_DStringFree(&buf);
- } else {
- char *data;
-
- /*
- * Store binary data in the registry.
- */
-
- data = Tcl_GetByteArrayFromObj(dataObj, &length);
- result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type,
- (BYTE *)data, length);
- }
- Tcl_DStringFree(&nameBuf);
- RegCloseKey(key);
- if (result != ERROR_SUCCESS) {
- Tcl_AppendToObj(resultPtr, "unable to set value: ", -1);
- AppendSystemError(interp, result);
- return TCL_ERROR;
- }
- 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;
- WCHAR *wMsgPtr;
- char *msg;
- char id[TCL_INTEGER_SPACE], msgBuf[24 + TCL_INTEGER_SPACE];
- Tcl_DString ds;
- Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
-
- length = FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM
- | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error,
- MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (WCHAR *) &wMsgPtr,
- 0, NULL);
- if (length == 0) {
- char *msgPtr;
-
- length = FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM
- | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error,
- MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (char *) &msgPtr,
- 0, NULL);
- if (length > 0) {
- wMsgPtr = (WCHAR *) LocalAlloc(LPTR, (length + 1) * sizeof(WCHAR));
- MultiByteToWideChar(CP_ACP, 0, msgPtr, length + 1, wMsgPtr,
- length + 1);
- LocalFree(msgPtr);
- }
- }
- if (length == 0) {
- if (error == ERROR_CALL_NOT_IMPLEMENTED) {
- msg = "function not supported under Win32s";
- } else {
- sprintf(msgBuf, "unknown error: %d", error);
- msg = msgBuf;
- }
- } else {
- Tcl_Encoding encoding;
-
- encoding = Tcl_GetEncoding(NULL, "unicode");
- Tcl_ExternalToUtfDString(encoding, (char *) wMsgPtr, -1, &ds);
- Tcl_FreeEncoding(encoding);
- LocalFree(wMsgPtr);
-
- msg = Tcl_DStringValue(&ds);
- length = Tcl_DStringLength(&ds);
-
- /*
- * Trim the trailing CR/LF from the system message.
- */
- if (msg[length-1] == '\n') {
- msg[--length] = 0;
- }
- if (msg[length-1] == '\r') {
- msg[--length] = 0;
- }
- }
-
- sprintf(id, "%d", error);
- Tcl_SetErrorCode(interp, "WINDOWS", id, msg, (char *) NULL);
- Tcl_AppendToObj(resultPtr, msg, length);
-
- 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. */
-{
- DWORD order = 1;
- DWORD localType;
-
- /*
- * Check to see if the low bit is in the first byte.
- */
-
- localType = (*((char*)(&order)) == 1) ? REG_DWORD : REG_DWORD_BIG_ENDIAN;
- return (type != localType) ? SWAPLONG(value) : value;
-}
diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c
deleted file mode 100644
index 8e1da0a..0000000
--- a/win/tclWinSerial.c
+++ /dev/null
@@ -1,1206 +0,0 @@
-/*
- * 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.
- * Changes by Rolf.Schroedter@dlr.de June 25-27, 1999
- *
- * RCS: @(#) $Id: tclWinSerial.c,v 1.9.2.1 2000/07/27 01:39:26 hobbs Exp $
- */
-
-#include "tclWinInt.h"
-
-#include <dos.h>
-#include <fcntl.h>
-#include <io.h>
-#include <sys/stat.h>
-
-/*
- * The following variable is used to tell whether this module has been
- * initialized.
- */
-
-static int initialized = 0;
-
-/*
- * 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)
-#define SERIAL_WRITE (1<<5) /* enables fileevent writable
- * one time after write operation */
-
-/*
- * 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 )
-
-/*
- * 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 writable; /* flag that the channel is readable */
- int readable; /* flag that the channel is readable */
- int blockTime; /* max. blocktime in msec */
- DWORD error; /* pending error code returned by
- * ClearCommError() */
- DWORD lastError; /* last error code, can be fetched with
- * fconfigure chan -lasterror */
-} SerialInfo;
-
-typedef struct ThreadSpecificData {
- /*
- * 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 SerialEvent {
- 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;
-
-COMMTIMEOUTS timeout_sync = { /* Timouts for blocking mode */
- MAXDWORD, /* ReadIntervalTimeout */
- MAXDWORD, /* ReadTotalTimeoutMultiplier */
- MAXDWORD-1, /* ReadTotalTimeoutConstant,
- MAXDWORD-1 works for both Win95/NT */
- 0, /* WriteTotalTimeoutMultiplier */
- 0, /* WriteTotalTimeoutConstant */
-};
-
-COMMTIMEOUTS timeout_async = { /* Timouts for non-blocking mode */
- 0, /* ReadIntervalTimeout */
- 0, /* ReadTotalTimeoutMultiplier */
- 1, /* 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, 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 _ANSI_ARGS_((ClientData instanceData,
- Tcl_Interp *interp, char *optionName,
- Tcl_DString *dsPtr));
-static int SerialSetOptionProc _ANSI_ARGS_((ClientData instanceData,
- Tcl_Interp *interp, char *optionName,
- char *value));
-
-/*
- * This structure describes the channel type structure for command serial
- * based IO.
- */
-
-static Tcl_ChannelType serialChannelType = {
- "serial", /* Type name. */
- TCL_CHANNEL_VERSION_2, /* v2 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. */
-};
-
-/*
- *----------------------------------------------------------------------
- *
- * SerialInit --
- *
- * This function initializes the static variables for this file.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Creates a new event source.
- *
- *----------------------------------------------------------------------
- */
-
-static ThreadSpecificData *
-SerialInit()
-{
- ThreadSpecificData *tsdPtr;
-
- /*
- * Check the initialized flag first, then check it again in the mutex.
- * This is a speed enhancement.
- */
-
- if (!initialized) {
- if (!initialized) {
- initialized = 1;
- Tcl_CreateExitHandler(ProcExitHandler, NULL);
- }
- }
-
- 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 */
-{
- 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 */
-{
- initialized = 0;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SerialBlockTime --
- *
- * Wrapper to set Tcl's block time in msec
- *
- * Results:
- * None.
- *----------------------------------------------------------------------
- */
-
-void
-SerialBlockTime(
- int msec) /* milli-seconds */
-{
- Tcl_Time blockTime;
-
- blockTime.sec = msec / 1000;
- blockTime.usec = (msec % 1000) * 1000;
- Tcl_SetMaxBlockTime(&blockTime);
-}
-/*
- *----------------------------------------------------------------------
- *
- * 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 | 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;
-
- 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 any READABLE or WRITABLE watch mask is set
- * call ClearCommError to poll cbInQue,cbOutQue
- * Window errors are ignored here
- */
-
- if( infoPtr->watchMask & (TCL_WRITABLE | TCL_READABLE) ) {
- if( ClearCommError( infoPtr->handle, &infoPtr->error, &cStat ) ) {
- /*
- * Look for empty output buffer. If empty, poll.
- */
-
- if( infoPtr->watchMask & TCL_WRITABLE ) {
- /*
- * force fileevent after serial write error
- */
- if (((infoPtr->flags & SERIAL_WRITE) != 0) &&
- ((cStat.cbOutQue == 0) ||
- (infoPtr->error & SERIAL_WRITE_ERRORS))) {
- /*
- * allow only one fileevent after each callback
- */
-
- infoPtr->flags &= ~SERIAL_WRITE;
- infoPtr->writable = 1;
- needEvent = 1;
- }
- }
-
- /*
- * 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;
- needEvent = 1;
- }
- }
- }
- }
-
- /*
- * Queue an event if the serial is signaled for reading or writing.
- */
-
- if (needEvent) {
- infoPtr->flags |= SERIAL_PENDING;
- evPtr = (SerialEvent *) 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. */
-{
- COMMTIMEOUTS *timeout;
- int errorCode = 0;
-
- SerialInfo *infoPtr = (SerialInfo *) instanceData;
-
- /*
- * Serial IO on Windows can not be switched between blocking & 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 |= SERIAL_ASYNC;
- timeout = &timeout_async;
- } else {
- infoPtr->flags &= ~(SERIAL_ASYNC);
- timeout = &timeout_sync;
- }
- if (SetCommTimeouts(infoPtr->handle, timeout) == FALSE) {
- TclWinConvertError(GetLastError());
- errorCode = errno;
- }
- return errorCode;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SerialCloseProc --
- *
- * Closes a serial based IO channel.
- *
- * Results:
- * 0 on success, errno otherwise.
- *
- * Side effects:
- * Closes the physical channel.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-SerialCloseProc(
- ClientData instanceData, /* Pointer to SerialInfo structure. */
- Tcl_Interp *interp) /* For error reporting. */
-{
- SerialInfo *serialPtr = (SerialInfo *) instanceData;
- int errorCode, result = 0;
- SerialInfo *infoPtr, **nextPtrPtr;
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
-
- errorCode = 0;
- serialPtr->validMask &= ~TCL_READABLE;
- serialPtr->validMask &= ~TCL_WRITABLE;
-
- /*
- * Don't close the Win32 handle if the handle is a standard channel
- * during the exit process. Otherwise, one thread may kill the stdio
- * of another.
- */
-
- if (!TclInExit()
- || ((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.
- */
-
- ckfree((char*) serialPtr);
-
- if (errorCode == 0) {
- return result;
- }
- return errorCode;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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;
- DWORD err;
- 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 = EAGAIN;
- 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;
- }
-
- if (ReadFile(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize, &bytesRead,
- NULL) == FALSE) {
- err = GetLastError();
- if (err != ERROR_IO_PENDING) {
- goto error;
- }
- }
- return bytesRead;
-
- error:
- TclWinConvertError(GetLastError());
- *errorCode = errno;
- return -1;
-
- 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. */
- 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, err;
-
- *errorCode = 0;
-
- /*
- * 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 */
- *errorCode = EIO; /* to return read-error only once */
- return -1;
- }
-
- /*
- * Check for a background error on the last write.
- * Allow one write-fileevent after each callback
- */
-
- if( toWrite ) {
- infoPtr->flags |= SERIAL_WRITE;
- }
-
- if (WriteFile(infoPtr->handle, (LPVOID) buf, (DWORD) toWrite,
- &bytesWritten, NULL) == FALSE) {
- err = GetLastError();
- if (err != ERROR_IO_PENDING) {
- TclWinConvertError(GetLastError());
- goto error;
- }
- }
-
- return bytesWritten;
-
-error:
- *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;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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, channelName, permissions)
- HANDLE handle;
- char *channelName;
- int permissions;
-{
- SerialInfo *infoPtr;
- ThreadSpecificData *tsdPtr;
-
- tsdPtr = SerialInit();
-
- SetupComm(handle, 4096, 4096);
- PurgeComm(handle, PURGE_TXABORT | PURGE_RXABORT | PURGE_TXCLEAR
- | PURGE_RXCLEAR);
-
- /*
- * default is blocking
- */
-
- SetCommTimeouts(handle, &timeout_sync);
-
- infoPtr = (SerialInfo *) ckalloc((unsigned) sizeof(SerialInfo));
- memset(infoPtr, 0, sizeof(SerialInfo));
-
- infoPtr->validMask = permissions;
- infoPtr->handle = handle;
-
- /*
- * Use the pointer to keep the channel names unique, in case
- * the handles are shared between multiple channels (stdin/stdout).
- */
-
- wsprintfA(channelName, "file%lx", (int) infoPtr);
-
- infoPtr->channel = Tcl_CreateChannel(&serialChannelType, channelName,
- (ClientData) infoPtr, permissions);
-
-
- infoPtr->readable = infoPtr->writable = 0;
- infoPtr->blockTime = SERIAL_DEFAULT_BLOCKTIME;
- infoPtr->lastError = infoPtr->error = 0;
-
- /*
- * 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
- *
- *----------------------------------------------------------------------
- */
-static void
-SerialErrorStr(error, dsPtr)
- DWORD error; /* Win32 serial error code */
- Tcl_DString *dsPtr; /* Where to store string */
-{
- if( (error & CE_RXOVER) != 0) {
- Tcl_DStringAppendElement(dsPtr, "RXOVER");
- }
- if( (error & CE_OVERRUN) != 0) {
- Tcl_DStringAppendElement(dsPtr, "OVERRUN");
- }
- if( (error & CE_RXPARITY) != 0) {
- Tcl_DStringAppendElement(dsPtr, "RXPARITY");
- }
- if( (error & CE_FRAME) != 0) {
- Tcl_DStringAppendElement(dsPtr, "FRAME");
- }
- if( (error & CE_BREAK) != 0) {
- Tcl_DStringAppendElement(dsPtr, "BREAK");
- }
- if( (error & CE_TXFULL) != 0) {
- Tcl_DStringAppendElement(dsPtr, "TXFULL");
- }
- if( (error & ~(SERIAL_READ_ERRORS | SERIAL_WRITE_ERRORS)) != 0) {
- char buf[TCL_INTEGER_SPACE + 1];
- wsprintfA(buf, "%d", error);
- Tcl_DStringAppendElement(dsPtr, buf);
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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(instanceData, interp, optionName, value)
- ClientData instanceData; /* File state. */
- Tcl_Interp *interp; /* For error reporting - can be NULL. */
- char *optionName; /* Which option to set? */
- char *value; /* New value for option. */
-{
- SerialInfo *infoPtr;
- DCB dcb;
- int len;
- BOOL result;
- Tcl_DString ds;
- TCHAR *native;
-
- infoPtr = (SerialInfo *) instanceData;
-
- len = strlen(optionName);
- if ((len > 1) && (strncmp(optionName, "-mode", len) == 0)) {
- if (GetCommState(infoPtr->handle, &dcb)) {
- native = Tcl_WinUtfToTChar(value, -1, &ds);
- result = (*tclWinProcs->buildCommDCBProc)(native, &dcb);
- Tcl_DStringFree(&ds);
-
- if ((result == FALSE) ||
- (SetCommState(infoPtr->handle, &dcb) == FALSE)) {
- /*
- * one should separate the 2 errors...
- */
-
- if (interp) {
- Tcl_AppendResult(interp,
- "bad value for -mode: should be ",
- "baud,parity,data,stop", NULL);
- }
- return TCL_ERROR;
- } else {
- return TCL_OK;
- }
- } else {
- if (interp) {
- Tcl_AppendResult(interp, "can't get comm state", NULL);
- }
- return TCL_ERROR;
- }
- } else if ((len > 1) &&
- (strncmp(optionName, "-pollinterval", len) == 0)) {
- if ( Tcl_GetInt(interp, value, &(infoPtr->blockTime)) != TCL_OK ) {
- return TCL_ERROR;
- }
- } else {
- return Tcl_BadChannelOption(interp, optionName,
- "mode pollinterval");
- }
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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(instanceData, interp, optionName, dsPtr)
- ClientData instanceData; /* File state. */
- Tcl_Interp *interp; /* For error reporting - can be NULL. */
- char *optionName; /* Option to get. */
- Tcl_DString *dsPtr; /* Where to store value(s). */
-{
- SerialInfo *infoPtr;
- DCB dcb;
- int 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 > 1) && (strncmp(optionName, "-mode", len) == 0))) {
- valid = 1;
- if (GetCommState(infoPtr->handle, &dcb) == 0) {
- /*
- * shouldn't we flag an error instead ?
- */
-
- Tcl_DStringAppendElement(dsPtr, "");
-
- } else {
- char parity;
- char *stop;
- char buf[2 * TCL_INTEGER_SPACE + 16];
-
- 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 -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);
- }
-
- if (valid) {
- return TCL_OK;
- } else {
- return Tcl_BadChannelOption(interp, optionName,
- "mode pollinterval lasterror");
- }
-}
diff --git a/win/tclWinSock.c b/win/tclWinSock.c
deleted file mode 100644
index 24429f4..0000000
--- a/win/tclWinSock.c
+++ /dev/null
@@ -1,2456 +0,0 @@
-/*
- * 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.
- *
- * RCS: @(#) $Id: tclWinSock.c,v 1.18.2.1 2000/07/27 01:39:26 hobbs Exp $
- */
-
-#include "tclWinInt.h"
-
-/*
- * The following variable is used to tell whether this module has been
- * initialized.
- */
-
-static int initialized = 0;
-
-static int hostnameInitialized = 0;
-static char hostname[255]; /* This buffer should be big enough for
- * hostname plus domain name. */
-
-TCL_DECLARE_MUTEX(socketMutex)
-
-/*
- * The following structure contains pointers to all of the WinSock API entry
- * points used by Tcl. It is initialized by InitSockets. Since we
- * dynamically load Winsock.dll on demand, we must use this function table
- * to refer to functions in the socket API.
- */
-
-static struct {
- HINSTANCE hInstance; /* Handle to WinSock library. */
- SOCKET (PASCAL FAR *accept)(SOCKET s, struct sockaddr FAR *addr,
- int FAR *addrlen);
- int (PASCAL FAR *bind)(SOCKET s, const struct sockaddr FAR *addr,
- int namelen);
- int (PASCAL FAR *closesocket)(SOCKET s);
- int (PASCAL FAR *connect)(SOCKET s, const struct sockaddr FAR *name,
- int namelen);
- int (PASCAL FAR *ioctlsocket)(SOCKET s, long cmd, u_long FAR *argp);
- int (PASCAL FAR *getsockopt)(SOCKET s, int level, int optname,
- char FAR * optval, int FAR *optlen);
- u_short (PASCAL FAR *htons)(u_short hostshort);
- unsigned long (PASCAL FAR *inet_addr)(const char FAR * cp);
- char FAR * (PASCAL FAR *inet_ntoa)(struct in_addr in);
- int (PASCAL FAR *listen)(SOCKET s, int backlog);
- u_short (PASCAL FAR *ntohs)(u_short netshort);
- int (PASCAL FAR *recv)(SOCKET s, char FAR * buf, int len, int flags);
- int (PASCAL FAR *select)(int nfds, fd_set FAR * readfds,
- fd_set FAR * writefds, fd_set FAR * exceptfds,
- const struct timeval FAR * tiemout);
- int (PASCAL FAR *send)(SOCKET s, const char FAR * buf, int len, int flags);
- int (PASCAL FAR *setsockopt)(SOCKET s, int level, int optname,
- const char FAR * optval, int optlen);
- int (PASCAL FAR *shutdown)(SOCKET s, int how);
- SOCKET (PASCAL FAR *socket)(int af, int type, int protocol);
- struct hostent FAR * (PASCAL FAR *gethostbyname)(const char FAR * name);
- struct hostent FAR * (PASCAL FAR *gethostbyaddr)(const char FAR *addr,
- int addrlen, int addrtype);
- int (PASCAL FAR *gethostname)(char FAR * name, int namelen);
- int (PASCAL FAR *getpeername)(SOCKET sock, struct sockaddr FAR *name,
- int FAR *namelen);
- struct servent FAR * (PASCAL FAR *getservbyname)(const char FAR * name,
- const char FAR * proto);
- int (PASCAL FAR *getsockname)(SOCKET sock, struct sockaddr FAR *name,
- int FAR *namelen);
- int (PASCAL FAR *WSAStartup)(WORD wVersionRequired, LPWSADATA lpWSAData);
- int (PASCAL FAR *WSACleanup)(void);
- int (PASCAL FAR *WSAGetLastError)(void);
- int (PASCAL FAR *WSAAsyncSelect)(SOCKET s, HWND hWnd, u_int wMsg,
- long lEvent);
-} winSock;
-
-/*
- * 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
-
-/*
- * The following structure is used to store the data associated with
- * each socket.
- */
-
-typedef struct SocketInfo {
- Tcl_Channel channel; /* Channel associated with this socket. */
- SOCKET socket; /* Windows SOCKET handle. */
- int flags; /* Bit field comprised of the flags
- * described below. */
- int watchEvents; /* OR'ed combination of FD_READ, FD_WRITE,
- * FD_CLOSE, FD_ACCEPT and FD_CONNECT that
- * indicate which events are interesting. */
- int readyEvents; /* OR'ed combination of FD_READ, FD_WRITE,
- * FD_CLOSE, FD_ACCEPT and FD_CONNECT that
- * indicate which events have occurred. */
- int selectEvents; /* OR'ed combination of FD_READ, FD_WRITE,
- * FD_CLOSE, FD_ACCEPT and FD_CONNECT that
- * indicate which events are currently
- * being selected. */
- int acceptEventCount; /* Count of the current number of FD_ACCEPTs
- * that have arrived and not processed. */
- Tcl_TcpAcceptProc *acceptProc; /* Proc to call on accept. */
- ClientData acceptProcData; /* The data for the accept proc. */
- int lastError; /* Error code from last message. */
- struct SocketInfo *nextPtr; /* The next socket on the global socket
- * list. */
-} SocketInfo;
-
-/*
- * The following structure is what is added to the Tcl event queue when
- * a socket event occurs.
- */
-
-typedef struct SocketEvent {
- Tcl_Event header; /* Information that is standard for
- * all events. */
- SOCKET socket; /* Socket descriptor that is ready. Used
- * to find the SocketInfo structure for
- * the file (can't point directly to the
- * SocketInfo 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
-
-/*
- * The following macros may be used to set the flags field of
- * a SocketInfo structure.
- */
-
-#define SOCKET_ASYNC (1<<0) /* The socket is in blocking mode. */
-#define SOCKET_EOF (1<<1) /* A zero read happened on
- * the socket. */
-#define SOCKET_ASYNC_CONNECT (1<<2) /* This socket uses async connect. */
-#define SOCKET_PENDING (1<<3) /* A message has been sent
- * for this socket */
-
-typedef struct ThreadSpecificData {
- /*
- * Every open socket has an entry on the following list.
- */
-
- 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 */
- SocketInfo *socketList;
-} ThreadSpecificData;
-
-static Tcl_ThreadDataKey dataKey;
-static WNDCLASSA windowClass;
-
-/*
- * Static functions defined in this file.
- */
-
-static SocketInfo * CreateSocket _ANSI_ARGS_((Tcl_Interp *interp,
- int port, char *host, int server, char *myaddr,
- int myport, int async));
-static int CreateSocketAddress _ANSI_ARGS_(
- (struct sockaddr_in *sockaddrPtr,
- char *host, int port));
-static void InitSockets _ANSI_ARGS_((void));
-static SocketInfo * NewSocketInfo _ANSI_ARGS_((SOCKET socket));
-static void SocketCheckProc _ANSI_ARGS_((ClientData clientData,
- int flags));
-static int SocketEventProc _ANSI_ARGS_((Tcl_Event *evPtr,
- int flags));
-static void SocketExitHandler _ANSI_ARGS_((ClientData clientData));
-static LRESULT CALLBACK SocketProc _ANSI_ARGS_((HWND hwnd, UINT message,
- WPARAM wParam, LPARAM lParam));
-static void SocketSetupProc _ANSI_ARGS_((ClientData clientData,
- int flags));
-static void SocketThreadExitHandler _ANSI_ARGS_((ClientData clientData));
-static int SocketsEnabled _ANSI_ARGS_((void));
-static void TcpAccept _ANSI_ARGS_((SocketInfo *infoPtr));
-static int TcpBlockProc _ANSI_ARGS_((ClientData instanceData,
- int mode));
-static int TcpCloseProc _ANSI_ARGS_((ClientData instanceData,
- Tcl_Interp *interp));
-static int TcpGetOptionProc _ANSI_ARGS_((ClientData instanceData,
- Tcl_Interp *interp, char *optionName,
- Tcl_DString *optionValue));
-static int TcpInputProc _ANSI_ARGS_((ClientData instanceData,
- char *buf, int toRead, int *errorCode));
-static int TcpOutputProc _ANSI_ARGS_((ClientData instanceData,
- char *buf, int toWrite, int *errorCode));
-static void TcpWatchProc _ANSI_ARGS_((ClientData instanceData,
- int mask));
-static int TcpGetHandleProc _ANSI_ARGS_((ClientData instanceData,
- int direction, ClientData *handlePtr));
-static int WaitForSocketEvent _ANSI_ARGS_((SocketInfo *infoPtr,
- int events, int *errorCodePtr));
-static DWORD WINAPI SocketThread _ANSI_ARGS_((LPVOID arg));
-
-/*
- * This structure describes the channel type structure for TCP socket
- * based IO.
- */
-
-static Tcl_ChannelType tcpChannelType = {
- "tcp", /* Type name. */
- TCL_CHANNEL_VERSION_2, /* v2 channel */
- TcpCloseProc, /* Close proc. */
- TcpInputProc, /* Input proc. */
- TcpOutputProc, /* Output proc. */
- NULL, /* Seek proc. */
- NULL, /* Set option proc. */
- TcpGetOptionProc, /* Get option proc. */
- TcpWatchProc, /* Set up notifier to watch this channel. */
- TcpGetHandleProc, /* Get an OS handle from channel. */
- NULL, /* close2proc. */
- TcpBlockProc, /* Set blocking/non-blocking mode. */
- NULL, /* flush proc. */
- NULL, /* handler proc. */
-};
-
-/*
- * Define version of Winsock required by Tcl.
- */
-
-#define WSA_VERSION_REQD MAKEWORD(1,1)
-
-/*
- *----------------------------------------------------------------------
- *
- * InitSockets --
- *
- * Initialize the socket module. Attempts to load the wsock32.dll
- * library and set up the winSock function table. If successful,
- * registers the event window for the socket notifier code.
- *
- * Assumes Mutex is held.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Dynamically loads wsock32.dll, and registers a new window
- * class and creates a window for use in asynchronous socket
- * notification.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-InitSockets()
-{
- DWORD id;
- WSADATA wsaData;
- ThreadSpecificData *tsdPtr =
- (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
-
- if (! initialized) {
- initialized = 1;
- Tcl_CreateExitHandler(SocketExitHandler, (ClientData) NULL);
-
- winSock.hInstance = LoadLibraryA("wsock32.dll");
-
- /*
- * Initialize the function table.
- */
-
- if (!SocketsEnabled()) {
- return;
- }
-
- winSock.accept = (SOCKET (PASCAL FAR *)(SOCKET s,
- struct sockaddr FAR *addr, int FAR *addrlen))
- GetProcAddress(winSock.hInstance, "accept");
- winSock.bind = (int (PASCAL FAR *)(SOCKET s,
- const struct sockaddr FAR *addr, int namelen))
- GetProcAddress(winSock.hInstance, "bind");
- winSock.closesocket = (int (PASCAL FAR *)(SOCKET s))
- GetProcAddress(winSock.hInstance, "closesocket");
- winSock.connect = (int (PASCAL FAR *)(SOCKET s,
- const struct sockaddr FAR *name, int namelen))
- GetProcAddress(winSock.hInstance, "connect");
- winSock.ioctlsocket = (int (PASCAL FAR *)(SOCKET s, long cmd,
- u_long FAR *argp))
- GetProcAddress(winSock.hInstance, "ioctlsocket");
- winSock.getsockopt = (int (PASCAL FAR *)(SOCKET s,
- int level, int optname, char FAR * optval, int FAR *optlen))
- GetProcAddress(winSock.hInstance, "getsockopt");
- winSock.htons = (u_short (PASCAL FAR *)(u_short hostshort))
- GetProcAddress(winSock.hInstance, "htons");
- winSock.inet_addr = (unsigned long (PASCAL FAR *)(const char FAR *cp))
- GetProcAddress(winSock.hInstance, "inet_addr");
- winSock.inet_ntoa = (char FAR * (PASCAL FAR *)(struct in_addr in))
- GetProcAddress(winSock.hInstance, "inet_ntoa");
- winSock.listen = (int (PASCAL FAR *)(SOCKET s, int backlog))
- GetProcAddress(winSock.hInstance, "listen");
- winSock.ntohs = (u_short (PASCAL FAR *)(u_short netshort))
- GetProcAddress(winSock.hInstance, "ntohs");
- winSock.recv = (int (PASCAL FAR *)(SOCKET s, char FAR * buf,
- int len, int flags)) GetProcAddress(winSock.hInstance, "recv");
- winSock.select = (int (PASCAL FAR *)(int nfds, fd_set FAR * readfds,
- fd_set FAR * writefds, fd_set FAR * exceptfds,
- const struct timeval FAR * tiemout))
- GetProcAddress(winSock.hInstance, "select");
- winSock.send = (int (PASCAL FAR *)(SOCKET s, const char FAR * buf,
- int len, int flags)) GetProcAddress(winSock.hInstance, "send");
- winSock.setsockopt = (int (PASCAL FAR *)(SOCKET s, int level,
- int optname, const char FAR * optval, int optlen))
- GetProcAddress(winSock.hInstance, "setsockopt");
- winSock.shutdown = (int (PASCAL FAR *)(SOCKET s, int how))
- GetProcAddress(winSock.hInstance, "shutdown");
- winSock.socket = (SOCKET (PASCAL FAR *)(int af, int type,
- int protocol)) GetProcAddress(winSock.hInstance, "socket");
- winSock.gethostbyaddr = (struct hostent FAR * (PASCAL FAR *)
- (const char FAR *addr, int addrlen, int addrtype))
- GetProcAddress(winSock.hInstance, "gethostbyaddr");
- winSock.gethostbyname = (struct hostent FAR * (PASCAL FAR *)
- (const char FAR *name))
- GetProcAddress(winSock.hInstance, "gethostbyname");
- winSock.gethostname = (int (PASCAL FAR *)(char FAR * name,
- int namelen)) GetProcAddress(winSock.hInstance, "gethostname");
- winSock.getpeername = (int (PASCAL FAR *)(SOCKET sock,
- struct sockaddr FAR *name, int FAR *namelen))
- GetProcAddress(winSock.hInstance, "getpeername");
- winSock.getservbyname = (struct servent FAR * (PASCAL FAR *)
- (const char FAR * name, const char FAR * proto))
- GetProcAddress(winSock.hInstance, "getservbyname");
- winSock.getsockname = (int (PASCAL FAR *)(SOCKET sock,
- struct sockaddr FAR *name, int FAR *namelen))
- GetProcAddress(winSock.hInstance, "getsockname");
- winSock.WSAStartup = (int (PASCAL FAR *)(WORD wVersionRequired,
- LPWSADATA lpWSAData)) GetProcAddress(winSock.hInstance, "WSAStartup");
- winSock.WSACleanup = (int (PASCAL FAR *)(void))
- GetProcAddress(winSock.hInstance, "WSACleanup");
- winSock.WSAGetLastError = (int (PASCAL FAR *)(void))
- GetProcAddress(winSock.hInstance, "WSAGetLastError");
- winSock.WSAAsyncSelect = (int (PASCAL FAR *)(SOCKET s, HWND hWnd,
- u_int wMsg, long lEvent))
- GetProcAddress(winSock.hInstance, "WSAAsyncSelect");
-
- /*
- * Now check that all fields are properly initialized. If not, return
- * zero to indicate that we failed to initialize properly.
- */
-
- if ((winSock.hInstance == NULL) ||
- (winSock.accept == NULL) ||
- (winSock.bind == NULL) ||
- (winSock.closesocket == NULL) ||
- (winSock.connect == NULL) ||
- (winSock.ioctlsocket == NULL) ||
- (winSock.getsockopt == NULL) ||
- (winSock.htons == NULL) ||
- (winSock.inet_addr == NULL) ||
- (winSock.inet_ntoa == NULL) ||
- (winSock.listen == NULL) ||
- (winSock.ntohs == NULL) ||
- (winSock.recv == NULL) ||
- (winSock.select == NULL) ||
- (winSock.send == NULL) ||
- (winSock.setsockopt == NULL) ||
- (winSock.socket == NULL) ||
- (winSock.gethostbyname == NULL) ||
- (winSock.gethostbyaddr == NULL) ||
- (winSock.gethostname == NULL) ||
- (winSock.getpeername == NULL) ||
- (winSock.getservbyname == NULL) ||
- (winSock.getsockname == NULL) ||
- (winSock.WSAStartup == NULL) ||
- (winSock.WSACleanup == NULL) ||
- (winSock.WSAGetLastError == NULL) ||
- (winSock.WSAAsyncSelect == NULL)) {
- goto unloadLibrary;
- }
-
- /*
- * 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 = "TclSocket";
- windowClass.lpfnWndProc = SocketProc;
- windowClass.hIcon = NULL;
- windowClass.hCursor = NULL;
-
- if (!RegisterClassA(&windowClass)) {
- TclWinConvertError(GetLastError());
- (*winSock.WSACleanup)();
- goto unloadLibrary;
- }
-
- /*
- * Initialize the winsock library and check the version number.
- */
-
- if ((*winSock.WSAStartup)(WSA_VERSION_REQD, &wsaData) != 0) {
- goto unloadLibrary;
- }
- if (wsaData.wVersion != WSA_VERSION_REQD) {
- (*winSock.WSACleanup)();
- goto unloadLibrary;
- }
- }
-
- /*
- * Check for per-thread initialization.
- */
-
- if (tsdPtr == NULL) {
- tsdPtr = TCL_TSD_INIT(&dataKey);
- tsdPtr->socketList = NULL;
- tsdPtr->hwnd = NULL;
-
- tsdPtr->threadId = Tcl_GetCurrentThread();
-
- tsdPtr->readyEvent = CreateEvent(NULL, FALSE, FALSE, NULL);
- tsdPtr->socketListLock = CreateEvent(NULL, FALSE, TRUE, NULL);
- tsdPtr->socketThread = CreateThread(NULL, 8000, SocketThread,
- tsdPtr, 0, &id);
- SetThreadPriority(tsdPtr->socketThread, THREAD_PRIORITY_HIGHEST);
-
- if (tsdPtr->socketThread == NULL) {
- goto unloadLibrary;
- }
-
-
- /*
- * Wait for the thread to signal that the window has
- * been created and is ready to go. Timeout after twenty
- * seconds.
- */
-
- if (WaitForSingleObject(tsdPtr->readyEvent, 20000) == WAIT_TIMEOUT) {
- goto unloadLibrary;
- }
-
- if (tsdPtr->hwnd == NULL) {
- goto unloadLibrary;
- }
-
- Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL);
- Tcl_CreateThreadExitHandler(SocketThreadExitHandler, NULL);
- }
- return;
-
-unloadLibrary:
- if (tsdPtr != NULL) {
- if (tsdPtr->hwnd != NULL) {
- DestroyWindow(tsdPtr->hwnd);
- }
- if (tsdPtr->socketThread != NULL) {
- TerminateThread(tsdPtr->socketThread, 0);
- tsdPtr->socketThread = NULL;
- }
- CloseHandle(tsdPtr->readyEvent);
- CloseHandle(tsdPtr->socketListLock);
- }
- FreeLibrary(winSock.hInstance);
- winSock.hInstance = NULL;
- return;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SocketsEnabled --
- *
- * Check that the WinSock DLL is loaded and ready.
- *
- * Results:
- * 1 if it is.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
- /* ARGSUSED */
-static int
-SocketsEnabled()
-{
- int enabled;
- Tcl_MutexLock(&socketMutex);
- enabled = (winSock.hInstance != NULL);
- Tcl_MutexUnlock(&socketMutex);
- return enabled;
-}
-
-
-/*
- *----------------------------------------------------------------------
- *
- * SocketExitHandler --
- *
- * Callback invoked during exit clean up to delete the socket
- * communication window and to release the WinSock DLL.
- *
- * Results:
- * None.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
- /* ARGSUSED */
-static void
-SocketExitHandler(clientData)
- ClientData clientData; /* Not used. */
-{
- Tcl_MutexLock(&socketMutex);
- if (winSock.hInstance) {
- UnregisterClassA("TclSocket", TclWinGetTclInstance());
- (*winSock.WSACleanup)();
- FreeLibrary(winSock.hInstance);
- winSock.hInstance = NULL;
- }
- initialized = 0;
- hostnameInitialized = 0;
- Tcl_MutexUnlock(&socketMutex);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SocketThreadExitHandler --
- *
- * Callback invoked during thread clean up to delete the socket
- * event source.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Delete the event source.
- *
- *----------------------------------------------------------------------
- */
-
- /* ARGSUSED */
-static void
-SocketThreadExitHandler(clientData)
- ClientData clientData; /* Not used. */
-{
- ThreadSpecificData *tsdPtr =
- (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
-
- if (tsdPtr->socketThread != NULL) {
-
- PostMessage(tsdPtr->hwnd, SOCKET_TERMINATE, 0, 0);
-
- /*
- * Wait for the thread to terminate. This ensures that we are
- * completely cleaned up before we leave this function.
- */
-
- WaitForSingleObject(tsdPtr->socketThread, INFINITE);
- CloseHandle(tsdPtr->socketThread);
- CloseHandle(tsdPtr->readyEvent);
- CloseHandle(tsdPtr->socketListLock);
-
- }
- if (tsdPtr->hwnd != NULL) {
- DestroyWindow(tsdPtr->hwnd);
- }
-
- Tcl_DeleteEventSource(SocketSetupProc, SocketCheckProc, NULL);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclpHasSockets(interp)
- Tcl_Interp *interp;
-{
- Tcl_MutexLock(&socketMutex);
- InitSockets();
- Tcl_MutexUnlock(&socketMutex);
-
- if (SocketsEnabled()) {
- return TCL_OK;
- }
- if (interp != NULL) {
- Tcl_AppendResult(interp, "sockets are not available on this system",
- NULL);
- }
- return TCL_ERROR;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SocketSetupProc --
- *
- * This procedure is invoked before Tcl_DoOneEvent blocks waiting
- * for an event.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Adjusts the block time if needed.
- *
- *----------------------------------------------------------------------
- */
-
-void
-SocketSetupProc(data, flags)
- ClientData data; /* Not used. */
- int flags; /* Event flags as passed to Tcl_DoOneEvent. */
-{
- SocketInfo *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 socket. If so, poll.
- */
-
- WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
- for (infoPtr = tsdPtr->socketList; infoPtr != NULL;
- infoPtr = infoPtr->nextPtr) {
- if (infoPtr->readyEvents & infoPtr->watchEvents) {
- Tcl_SetMaxBlockTime(&blockTime);
- break;
- }
- }
- SetEvent(tsdPtr->socketListLock);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SocketCheckProc --
- *
- * This procedure is called by Tcl_DoOneEvent to check the socket
- * event source for events.
- *
- * Results:
- * None.
- *
- * Side effects:
- * May queue an event.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-SocketCheckProc(data, flags)
- ClientData data; /* Not used. */
- int flags; /* Event flags as passed to Tcl_DoOneEvent. */
-{
- SocketInfo *infoPtr;
- 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 (infoPtr = tsdPtr->socketList; infoPtr != NULL;
- infoPtr = infoPtr->nextPtr) {
- if ((infoPtr->readyEvents & infoPtr->watchEvents)
- && !(infoPtr->flags & SOCKET_PENDING)) {
- infoPtr->flags |= SOCKET_PENDING;
- evPtr = (SocketEvent *) ckalloc(sizeof(SocketEvent));
- evPtr->header.proc = SocketEventProc;
- evPtr->socket = infoPtr->socket;
- Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
- }
- }
- SetEvent(tsdPtr->socketListLock);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SocketEventProc --
- *
- * This procedure is called by Tcl_ServiceEvent when a socket event
- * reaches the front of the event queue. This procedure 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 procedures do.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-SocketEventProc(evPtr, flags)
- Tcl_Event *evPtr; /* Event to service. */
- int flags; /* Flags that indicate what events to
- * handle, such as TCL_FILE_EVENTS. */
-{
- SocketInfo *infoPtr;
- SocketEvent *eventPtr = (SocketEvent *) evPtr;
- int mask = 0;
- int events;
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
-
- if (!(flags & TCL_FILE_EVENTS)) {
- return 0;
- }
-
- /*
- * Find the specified socket on the socket list.
- */
-
- WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
- for (infoPtr = tsdPtr->socketList; infoPtr != NULL;
- infoPtr = infoPtr->nextPtr) {
- if (infoPtr->socket == eventPtr->socket) {
- break;
- }
- }
- SetEvent(tsdPtr->socketListLock);
-
- /*
- * Discard events that have gone stale.
- */
-
- if (!infoPtr) {
- return 1;
- }
-
- infoPtr->flags &= ~SOCKET_PENDING;
-
- /*
- * Handle connection requests directly.
- */
-
- if (infoPtr->readyEvents & FD_ACCEPT) {
- TcpAccept(infoPtr);
- return 1;
- }
-
-
- /*
- * Mask off unwanted events and compute the read/write mask so
- * we can notify the channel.
- */
-
- events = infoPtr->readyEvents & infoPtr->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;
- } else if (events & FD_READ) {
- 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) infoPtr);
-
- FD_ZERO(&readFds);
- FD_SET(infoPtr->socket, &readFds);
- timeout.tv_usec = 0;
- timeout.tv_sec = 0;
-
- if ((*winSock.select)(0, &readFds, NULL, NULL, &timeout) != 0) {
- mask |= TCL_READABLE;
- } else {
- SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
- (WPARAM) SELECT, (LPARAM) infoPtr);
- infoPtr->readyEvents &= ~(FD_READ);
- }
- }
- if (events & (FD_WRITE | FD_CONNECT)) {
- mask |= TCL_WRITABLE;
- }
-
- if (mask) {
- Tcl_NotifyChannel(infoPtr->channel, mask);
- }
- return 1;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TcpBlockProc --
- *
- * Sets a socket into blocking or non-blocking mode.
- *
- * Results:
- * 0 if successful, errno if there was an error.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-TcpBlockProc(instanceData, mode)
- ClientData instanceData; /* The socket to block/un-block. */
- int mode; /* TCL_MODE_BLOCKING or
- * TCL_MODE_NONBLOCKING. */
-{
- SocketInfo *infoPtr = (SocketInfo *) instanceData;
-
- if (mode == TCL_MODE_NONBLOCKING) {
- infoPtr->flags |= SOCKET_ASYNC;
- } else {
- infoPtr->flags &= ~(SOCKET_ASYNC);
- }
- return 0;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TcpCloseProc --
- *
- * This procedure 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(instanceData, interp)
- ClientData instanceData; /* The socket to close. */
- Tcl_Interp *interp; /* Unused. */
-{
- SocketInfo *infoPtr = (SocketInfo *) instanceData;
- SocketInfo **nextPtrPtr;
- 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.
- */
-
- if ((*winSock.closesocket)(infoPtr->socket) == SOCKET_ERROR) {
- TclWinConvertWSAError((*winSock.WSAGetLastError)());
- errorCode = Tcl_GetErrno();
- }
- }
-
- /*
- * Remove the socket from socketList.
- */
-
- WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
- for (nextPtrPtr = &(tsdPtr->socketList); (*nextPtrPtr) != NULL;
- nextPtrPtr = &((*nextPtrPtr)->nextPtr)) {
- if ((*nextPtrPtr) == infoPtr) {
- (*nextPtrPtr) = infoPtr->nextPtr;
- break;
- }
- }
- SetEvent(tsdPtr->socketListLock);
-
- ckfree((char *) infoPtr);
- return errorCode;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * NewSocketInfo --
- *
- * This function allocates and initializes a new SocketInfo
- * structure.
- *
- * Results:
- * Returns a newly allocated SocketInfo.
- *
- * Side effects:
- * Adds the socket to the global socket list.
- *
- *----------------------------------------------------------------------
- */
-
-static SocketInfo *
-NewSocketInfo(socket)
- SOCKET socket;
-{
- SocketInfo *infoPtr;
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
-
- infoPtr = (SocketInfo *) ckalloc((unsigned) sizeof(SocketInfo));
- infoPtr->socket = socket;
- infoPtr->flags = 0;
- infoPtr->watchEvents = 0;
- infoPtr->readyEvents = 0;
- infoPtr->selectEvents = 0;
- infoPtr->acceptEventCount = 0;
- infoPtr->acceptProc = NULL;
- infoPtr->lastError = 0;
-
- WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
- infoPtr->nextPtr = tsdPtr->socketList;
- tsdPtr->socketList = infoPtr;
- SetEvent(tsdPtr->socketListLock);
-
- return infoPtr;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * CreateSocket --
- *
- * This function opens a new socket and initializes the
- * SocketInfo structure.
- *
- * Results:
- * Returns a new SocketInfo, or NULL with an error in interp.
- *
- * Side effects:
- * Adds a new socket to the socketList.
- *
- *----------------------------------------------------------------------
- */
-
-static SocketInfo *
-CreateSocket(interp, port, host, server, myaddr, myport, async)
- Tcl_Interp *interp; /* For error reporting; can be NULL. */
- int port; /* Port number to open. */
- char *host; /* Name of host on which to open port. */
- int server; /* 1 if socket should be a server socket,
- * else 0 for a client socket. */
- char *myaddr; /* Optional client-side address */
- int myport; /* Optional client-side port */
- int async; /* If nonzero, connect client socket
- * asynchronously. */
-{
- u_long flag = 1; /* Indicates nonblocking mode. */
- int asyncConnect = 0; /* Will be 1 if async connect is
- * in progress. */
- struct sockaddr_in sockaddr; /* Socket address */
- struct sockaddr_in mysockaddr; /* Socket address for client */
- SOCKET sock;
- SocketInfo *infoPtr; /* The returned value. */
- ThreadSpecificData *tsdPtr =
- (ThreadSpecificData *)TclThreadDataKeyGet(&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()) {
- return NULL;
- }
-
- if (! CreateSocketAddress(&sockaddr, host, port)) {
- goto error;
- }
- if ((myaddr != NULL || myport != 0) &&
- ! CreateSocketAddress(&mysockaddr, myaddr, myport)) {
- goto error;
- }
-
- sock = (*winSock.socket)(AF_INET, SOCK_STREAM, 0);
- if (sock == INVALID_SOCKET) {
- goto error;
- }
-
- /*
- * 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(sock, TCP_BUFFER_SIZE);
-
- if (server) {
- /*
- * Bind to the specified port. Note that we must not call setsockopt
- * with SO_REUSEADDR because Microsoft allows addresses to be reused
- * even if they are still in use.
- *
- * Bind should not be affected by the socket having already been
- * set into nonblocking mode. If there is trouble, this is one place
- * to look for bugs.
- */
-
- if ((*winSock.bind)(sock, (struct sockaddr *) &sockaddr,
- sizeof(sockaddr)) == SOCKET_ERROR) {
- goto error;
- }
-
- /*
- * 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 ((*winSock.listen)(sock, SOMAXCONN) == SOCKET_ERROR) {
- goto error;
- }
-
- /*
- * Add this socket to the global list of sockets.
- */
-
- infoPtr = NewSocketInfo(sock);
-
- /*
- * Set up the select mask for connection request events.
- */
-
- infoPtr->selectEvents = FD_ACCEPT;
- infoPtr->watchEvents |= FD_ACCEPT;
-
- } else {
-
- /*
- * Try to bind to a local port, if specified.
- */
-
- if (myaddr != NULL || myport != 0) {
- if ((*winSock.bind)(sock, (struct sockaddr *) &mysockaddr,
- sizeof(struct sockaddr)) == SOCKET_ERROR) {
- goto error;
- }
- }
-
- /*
- * Set the socket into nonblocking mode if the connect should be
- * done in the background.
- */
-
- if (async) {
- if ((*winSock.ioctlsocket)(sock, FIONBIO, &flag) == SOCKET_ERROR) {
- goto error;
- }
- }
-
- /*
- * Attempt to connect to the remote socket.
- */
-
- if ((*winSock.connect)(sock, (struct sockaddr *) &sockaddr,
- sizeof(sockaddr)) == SOCKET_ERROR) {
- TclWinConvertWSAError((*winSock.WSAGetLastError)());
- if (Tcl_GetErrno() != EWOULDBLOCK) {
- goto error;
- }
-
- /*
- * The connection is progressing in the background.
- */
-
- asyncConnect = 1;
- }
-
- /*
- * Add this socket to the global list of sockets.
- */
-
- infoPtr = NewSocketInfo(sock);
-
- /*
- * Set up the select mask for read/write events. If the connect
- * attempt has not completed, include connect events.
- */
-
- infoPtr->selectEvents = FD_READ | FD_WRITE | FD_CLOSE;
- if (asyncConnect) {
- infoPtr->flags |= SOCKET_ASYNC_CONNECT;
- infoPtr->selectEvents |= FD_CONNECT;
- }
- }
-
- /*
- * Register for interest in events in the select mask. Note that this
- * automatically places the socket into non-blocking mode.
- */
-
- (*winSock.ioctlsocket)(sock, FIONBIO, &flag);
- SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
- (WPARAM) SELECT, (LPARAM) infoPtr);
-
- return infoPtr;
-
-error:
- TclWinConvertWSAError((*winSock.WSAGetLastError)());
- if (interp != NULL) {
- Tcl_AppendResult(interp, "couldn't open socket: ",
- Tcl_PosixError(interp), (char *) NULL);
- }
- if (sock != INVALID_SOCKET) {
- (*winSock.closesocket)(sock);
- }
- return NULL;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * CreateSocketAddress --
- *
- * This function initializes a sockaddr structure for a host and port.
- *
- * Results:
- * 1 if the host was valid, 0 if the host could not be converted to
- * an IP address.
- *
- * Side effects:
- * Fills in the *sockaddrPtr structure.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-CreateSocketAddress(sockaddrPtr, host, port)
- struct sockaddr_in *sockaddrPtr; /* Socket address */
- char *host; /* Host. NULL implies INADDR_ANY */
- int port; /* Port number */
-{
- struct hostent *hostent; /* Host database entry */
- struct in_addr addr; /* For 64/32 bit madness */
-
- /*
- * Check that WinSock is initialized; do not call it if not, to
- * prevent system crashes. This can happen at exit time if the exit
- * handler for WinSock ran before other exit handlers that want to
- * use sockets.
- */
-
- if (!SocketsEnabled()) {
- Tcl_SetErrno(EFAULT);
- return 0;
- }
-
- (void) memset((char *) sockaddrPtr, '\0', sizeof(struct sockaddr_in));
- sockaddrPtr->sin_family = AF_INET;
- sockaddrPtr->sin_port = (*winSock.htons)((short) (port & 0xFFFF));
- if (host == NULL) {
- addr.s_addr = INADDR_ANY;
- } else {
- addr.s_addr = (*winSock.inet_addr)(host);
- if (addr.s_addr == INADDR_NONE) {
- hostent = (*winSock.gethostbyname)(host);
- if (hostent != NULL) {
- memcpy((char *) &addr,
- (char *) hostent->h_addr_list[0],
- (size_t) hostent->h_length);
- } else {
-#ifdef EHOSTUNREACH
- Tcl_SetErrno(EHOSTUNREACH);
-#else
-#ifdef ENXIO
- Tcl_SetErrno(ENXIO);
-#endif
-#endif
- return 0; /* Error. */
- }
- }
- }
-
- /*
- * NOTE: On 64 bit machines the assignment below is rumored to not
- * do the right thing. Please report errors related to this if you
- * observe incorrect behavior on 64 bit machines such as DEC Alphas.
- * Should we modify this code to do an explicit memcpy?
- */
-
- sockaddrPtr->sin_addr.s_addr = addr.s_addr;
- return 1; /* Success. */
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * WaitForSocketEvent --
- *
- * Waits until one of the specified events occurs on a socket.
- *
- * 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(infoPtr, events, errorCodePtr)
- SocketInfo *infoPtr; /* Information about this socket. */
- int events; /* Events to look for. */
- int *errorCodePtr; /* Where to store errors? */
-{
- int result = 1;
- int oldMode;
- ThreadSpecificData *tsdPtr =
- (ThreadSpecificData *)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) infoPtr);
-
- SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
- (WPARAM) SELECT, (LPARAM) infoPtr);
-
- while (1) {
-
- if (infoPtr->lastError) {
- *errorCodePtr = infoPtr->lastError;
- result = 0;
- break;
- } else if (infoPtr->readyEvents & events) {
- break;
- } else if (infoPtr->flags & SOCKET_ASYNC) {
- *errorCodePtr = EWOULDBLOCK;
- result = 0;
- break;
- }
-
- /*
- * Wait until something happens.
- */
- WaitForSingleObject(tsdPtr->readyEvent, INFINITE);
- }
-
- (void) Tcl_SetServiceMode(oldMode);
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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(interp, port, host, myaddr, myport, async)
- Tcl_Interp *interp; /* For error reporting; can be NULL. */
- int port; /* Port number to open. */
- char *host; /* Host on which to open port. */
- char *myaddr; /* Client-side address */
- int myport; /* Client-side port */
- int async; /* If nonzero, should connect
- * client socket asynchronously. */
-{
- SocketInfo *infoPtr;
- char channelName[16 + TCL_INTEGER_SPACE];
-
- if (TclpHasSockets(interp) != TCL_OK) {
- return NULL;
- }
-
- /*
- * Create a new client socket and wrap it in a channel.
- */
-
- infoPtr = CreateSocket(interp, port, host, 0, myaddr, myport, async);
- if (infoPtr == NULL) {
- return NULL;
- }
-
- wsprintfA(channelName, "sock%d", infoPtr->socket);
-
- infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
- (ClientData) infoPtr, (TCL_READABLE | TCL_WRITABLE));
- if (Tcl_SetChannelOption(interp, infoPtr->channel, "-translation",
- "auto crlf") == TCL_ERROR) {
- Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel);
- return (Tcl_Channel) NULL;
- }
- if (Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "")
- == TCL_ERROR) {
- Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel);
- return (Tcl_Channel) NULL;
- }
- return infoPtr->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.
- *
- * NOTE: Code contributed by Mark Diekhans (markd@grizzly.com)
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_Channel
-Tcl_MakeTcpClientChannel(sock)
- ClientData sock; /* The socket to wrap up into a channel. */
-{
- SocketInfo *infoPtr;
- char channelName[16 + TCL_INTEGER_SPACE];
- ThreadSpecificData *tsdPtr;
-
- if (TclpHasSockets(NULL) != TCL_OK) {
- return NULL;
- }
-
- tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
-
- /*
- * Set kernel space buffering and non-blocking.
- */
-
- TclSockMinimumBuffers((SOCKET) sock, TCP_BUFFER_SIZE);
-
- infoPtr = NewSocketInfo((SOCKET) sock);
-
- /*
- * Start watching for read/write events on the socket.
- */
-
- infoPtr->selectEvents = FD_READ | FD_CLOSE | FD_WRITE;
- SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
- (WPARAM) SELECT, (LPARAM) infoPtr);
-
- wsprintfA(channelName, "sock%d", infoPtr->socket);
- infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
- (ClientData) infoPtr, (TCL_READABLE | TCL_WRITABLE));
- Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto crlf");
- return infoPtr->channel;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_OpenTcpServer --
- *
- * Opens a TCP server socket and creates a channel around it.
- *
- * Results:
- * The channel or NULL if failed. An error message is returned
- * in the interpreter on failure.
- *
- * Side effects:
- * Opens a server socket and creates a new channel.
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_Channel
-Tcl_OpenTcpServer(interp, port, host, acceptProc, acceptProcData)
- Tcl_Interp *interp; /* For error reporting - may be
- * NULL. */
- int port; /* Port number to open. */
- char *host; /* Name of local host. */
- Tcl_TcpAcceptProc *acceptProc; /* Callback for accepting connections
- * from new clients. */
- ClientData acceptProcData; /* Data for the callback. */
-{
- SocketInfo *infoPtr;
- char channelName[16 + TCL_INTEGER_SPACE];
-
- if (TclpHasSockets(interp) != TCL_OK) {
- return NULL;
- }
-
- /*
- * Create a new client socket and wrap it in a channel.
- */
-
- infoPtr = CreateSocket(interp, port, host, 1, NULL, 0, 0);
- if (infoPtr == NULL) {
- return NULL;
- }
-
- infoPtr->acceptProc = acceptProc;
- infoPtr->acceptProcData = acceptProcData;
-
- wsprintfA(channelName, "sock%d", infoPtr->socket);
-
- infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
- (ClientData) infoPtr, 0);
- if (Tcl_SetChannelOption(interp, infoPtr->channel, "-eofchar", "")
- == TCL_ERROR) {
- Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel);
- return (Tcl_Channel) NULL;
- }
-
- return infoPtr->channel;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TcpAccept --
- * Accept a TCP socket connection. This is called by
- * SocketEventProc and it in turns calls the registered accept
- * procedure.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Invokes the accept proc which may invoke arbitrary Tcl code.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-TcpAccept(infoPtr)
- SocketInfo *infoPtr; /* Socket to accept. */
-{
- SOCKET newSocket;
- SocketInfo *newInfoPtr;
- struct sockaddr_in addr;
- int len;
- char channelName[16 + TCL_INTEGER_SPACE];
- ThreadSpecificData *tsdPtr =
- (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
-
- /*
- * Accept the incoming connection request.
- */
-
- len = sizeof(struct sockaddr_in);
-
- newSocket = (*winSock.accept)(infoPtr->socket,
- (struct sockaddr *)&addr,
- &len);
-
- /*
- * Clear the ready mask so we can detect the next connection request.
- * Note that connection requests are level triggered, so if there is
- * a request already pending, a new event will be generated.
- */
-
- if (newSocket == INVALID_SOCKET) {
- infoPtr->acceptEventCount = 0;
- infoPtr->readyEvents &= ~(FD_ACCEPT);
- return;
- }
-
- /*
- * It is possible that more than one FD_ACCEPT has been sent, so an extra
- * count must be kept. Decrement the count, and reset the readyEvent bit
- * if the count is no longer > 0.
- */
-
- infoPtr->acceptEventCount--;
-
- if (infoPtr->acceptEventCount <= 0) {
- infoPtr->readyEvents &= ~(FD_ACCEPT);
- }
-
- /*
- * 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);
-
- wsprintfA(channelName, "sock%d", newInfoPtr->socket);
- newInfoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
- (ClientData) newInfoPtr, (TCL_READABLE | TCL_WRITABLE));
- if (Tcl_SetChannelOption(NULL, newInfoPtr->channel, "-translation",
- "auto crlf") == TCL_ERROR) {
- Tcl_Close((Tcl_Interp *) NULL, newInfoPtr->channel);
- return;
- }
- if (Tcl_SetChannelOption(NULL, newInfoPtr->channel, "-eofchar", "")
- == TCL_ERROR) {
- Tcl_Close((Tcl_Interp *) NULL, newInfoPtr->channel);
- return;
- }
-
- /*
- * Invoke the accept callback procedure.
- */
-
- if (infoPtr->acceptProc != NULL) {
- (infoPtr->acceptProc) (infoPtr->acceptProcData,
- newInfoPtr->channel,
- (*winSock.inet_ntoa)(addr.sin_addr),
- (*winSock.ntohs)(addr.sin_port));
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TcpInputProc --
- *
- * This procedure is called by the generic IO level to read data from
- * a socket based channel.
- *
- * Results:
- * The number of bytes read or -1 on error.
- *
- * Side effects:
- * Consumes input from the socket.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-TcpInputProc(instanceData, buf, toRead, errorCodePtr)
- ClientData instanceData; /* The socket state. */
- char *buf; /* Where to store data. */
- int toRead; /* Maximum number of bytes to read. */
- int *errorCodePtr; /* Where to store error codes. */
-{
- SocketInfo *infoPtr = (SocketInfo *) instanceData;
- int bytesRead;
- int error;
- ThreadSpecificData *tsdPtr =
- (ThreadSpecificData *)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 (infoPtr->flags & SOCKET_EOF) {
- return 0;
- }
-
- /*
- * Check to see if the socket is connected before trying to read.
- */
-
- if ((infoPtr->flags & SOCKET_ASYNC_CONNECT)
- && ! WaitForSocketEvent(infoPtr, FD_CONNECT, errorCodePtr)) {
- 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) infoPtr);
- bytesRead = (*winSock.recv)(infoPtr->socket, buf, toRead, 0);
- infoPtr->readyEvents &= ~(FD_READ);
-
- /*
- * Check for end-of-file condition or successful read.
- */
-
- if (bytesRead == 0) {
- infoPtr->flags |= SOCKET_EOF;
- }
- if (bytesRead != SOCKET_ERROR) {
- break;
- }
-
- /*
- * If an error occurs after the FD_CLOSE has arrived,
- * then ignore the error and report an EOF.
- */
-
- if (infoPtr->readyEvents & FD_CLOSE) {
- infoPtr->flags |= SOCKET_EOF;
- bytesRead = 0;
- break;
- }
-
- /*
- * Check for error condition or underflow in non-blocking case.
- */
-
- error = (*winSock.WSAGetLastError)();
- if ((infoPtr->flags & SOCKET_ASYNC) || (error != WSAEWOULDBLOCK)) {
- TclWinConvertWSAError(error);
- *errorCodePtr = Tcl_GetErrno();
- bytesRead = -1;
- break;
- }
-
- /*
- * In the blocking case, wait until the file becomes readable
- * or closed and try again.
- */
-
- if (!WaitForSocketEvent(infoPtr, FD_READ|FD_CLOSE, errorCodePtr)) {
- bytesRead = -1;
- break;
- }
- }
-
- SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
- (WPARAM) SELECT, (LPARAM) infoPtr);
-
- return bytesRead;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TcpOutputProc --
- *
- * This procedure 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(instanceData, buf, toWrite, errorCodePtr)
- ClientData instanceData; /* The socket state. */
- char *buf; /* Where to get data. */
- int toWrite; /* Maximum number of bytes to write. */
- int *errorCodePtr; /* Where to store error codes. */
-{
- SocketInfo *infoPtr = (SocketInfo *) instanceData;
- int bytesWritten;
- int error;
- ThreadSpecificData *tsdPtr =
- (ThreadSpecificData *)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 to see if the socket is connected before trying to write.
- */
-
- if ((infoPtr->flags & SOCKET_ASYNC_CONNECT)
- && ! WaitForSocketEvent(infoPtr, FD_CONNECT, errorCodePtr)) {
- return -1;
- }
-
- while (1) {
- SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
- (WPARAM) UNSELECT, (LPARAM) infoPtr);
-
- bytesWritten = (*winSock.send)(infoPtr->socket, buf, toWrite, 0);
- if (bytesWritten != SOCKET_ERROR) {
- /*
- * Since Windows won't generate a new write event until we hit
- * an overflow condition, we need to force the event loop to
- * poll until the condition changes.
- */
-
- if (infoPtr->watchEvents & FD_WRITE) {
- Tcl_Time blockTime = { 0, 0 };
- Tcl_SetMaxBlockTime(&blockTime);
- }
- break;
- }
-
- /*
- * Check for error condition or overflow. In the event of overflow, we
- * need to clear the FD_WRITE flag so we can detect the next writable
- * event. Note that Windows only sends a new writable event after a
- * send fails with WSAEWOULDBLOCK.
- */
-
- error = (*winSock.WSAGetLastError)();
- if (error == WSAEWOULDBLOCK) {
- infoPtr->readyEvents &= ~(FD_WRITE);
- if (infoPtr->flags & SOCKET_ASYNC) {
- *errorCodePtr = EWOULDBLOCK;
- bytesWritten = -1;
- break;
- }
- } else {
- TclWinConvertWSAError(error);
- *errorCodePtr = Tcl_GetErrno();
- bytesWritten = -1;
- break;
- }
-
- /*
- * In the blocking case, wait until the file becomes writable
- * or closed and try again.
- */
-
- if (!WaitForSocketEvent(infoPtr, FD_WRITE|FD_CLOSE, errorCodePtr)) {
- bytesWritten = -1;
- break;
- }
- }
-
- SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
- (WPARAM) SELECT, (LPARAM) infoPtr);
-
- return bytesWritten;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-TcpGetOptionProc(instanceData, interp, optionName, dsPtr)
- ClientData instanceData; /* Socket state. */
- Tcl_Interp *interp; /* For error reporting - can be NULL */
- 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. */
-{
- SocketInfo *infoPtr;
- struct sockaddr_in sockname;
- struct sockaddr_in peername;
- struct hostent *hostEntPtr;
- SOCKET sock;
- int size = sizeof(struct sockaddr_in);
- size_t len = 0;
- char buf[TCL_INTEGER_SPACE];
-
- /*
- * 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_AppendResult(interp, "winsock is not initialized", NULL);
- }
- return TCL_ERROR;
- }
-
- infoPtr = (SocketInfo *) instanceData;
- sock = (int) infoPtr->socket;
- if (optionName != (char *) NULL) {
- len = strlen(optionName);
- }
-
- if ((len > 1) && (optionName[1] == 'e') &&
- (strncmp(optionName, "-error", len) == 0)) {
- int optlen;
- int err, ret;
-
- optlen = sizeof(int);
- ret = TclWinGetSockOpt(sock, SOL_SOCKET, SO_ERROR,
- (char *)&err, &optlen);
- if (ret == SOCKET_ERROR) {
- err = (*winSock.WSAGetLastError)();
- }
- if (err) {
- TclWinConvertWSAError(err);
- Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(Tcl_GetErrno()), -1);
- }
- return TCL_OK;
- }
-
- if ((len == 0) ||
- ((len > 1) && (optionName[1] == 'p') &&
- (strncmp(optionName, "-peername", len) == 0))) {
- if ((*winSock.getpeername)(sock, (struct sockaddr *) &peername, &size)
- == 0) {
- if (len == 0) {
- Tcl_DStringAppendElement(dsPtr, "-peername");
- Tcl_DStringStartSublist(dsPtr);
- }
- Tcl_DStringAppendElement(dsPtr,
- (*winSock.inet_ntoa)(peername.sin_addr));
- hostEntPtr = (*winSock.gethostbyaddr)(
- (char *) &(peername.sin_addr), sizeof(peername.sin_addr),
- AF_INET);
- if (hostEntPtr != (struct hostent *) NULL) {
- Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name);
- } else {
- Tcl_DStringAppendElement(dsPtr,
- (*winSock.inet_ntoa)(peername.sin_addr));
- }
- TclFormatInt(buf, (*winSock.ntohs)(peername.sin_port));
- Tcl_DStringAppendElement(dsPtr, buf);
- if (len == 0) {
- Tcl_DStringEndSublist(dsPtr);
- } else {
- return TCL_OK;
- }
- } else {
- /*
- * getpeername failed - but if we were asked for all the options
- * (len==0), don't flag an error at that point because it could
- * be an fconfigure request on a server socket. (which have
- * no peer). {copied from unix/tclUnixChan.c}
- */
- if (len) {
- TclWinConvertWSAError((*winSock.WSAGetLastError)());
- if (interp) {
- Tcl_AppendResult(interp, "can't get peername: ",
- Tcl_PosixError(interp),
- (char *) NULL);
- }
- return TCL_ERROR;
- }
- }
- }
-
- if ((len == 0) ||
- ((len > 1) && (optionName[1] == 's') &&
- (strncmp(optionName, "-sockname", len) == 0))) {
- if ((*winSock.getsockname)(sock, (struct sockaddr *) &sockname, &size)
- == 0) {
- if (len == 0) {
- Tcl_DStringAppendElement(dsPtr, "-sockname");
- Tcl_DStringStartSublist(dsPtr);
- }
- Tcl_DStringAppendElement(dsPtr,
- (*winSock.inet_ntoa)(sockname.sin_addr));
- hostEntPtr = (*winSock.gethostbyaddr)(
- (char *) &(sockname.sin_addr), sizeof(peername.sin_addr),
- AF_INET);
- if (hostEntPtr != (struct hostent *) NULL) {
- Tcl_DStringAppendElement(dsPtr, hostEntPtr->h_name);
- } else {
- Tcl_DStringAppendElement(dsPtr,
- (*winSock.inet_ntoa)(sockname.sin_addr));
- }
- TclFormatInt(buf, (*winSock.ntohs)(sockname.sin_port));
- Tcl_DStringAppendElement(dsPtr, buf);
- if (len == 0) {
- Tcl_DStringEndSublist(dsPtr);
- } else {
- return TCL_OK;
- }
- } else {
- if (interp) {
- TclWinConvertWSAError((*winSock.WSAGetLastError)());
- Tcl_AppendResult(interp, "can't get sockname: ",
- Tcl_PosixError(interp),
- (char *) NULL);
- }
- return TCL_ERROR;
- }
- }
-
- if (len > 0) {
- return Tcl_BadChannelOption(interp, optionName, "peername sockname");
- }
-
- 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(instanceData, mask)
- ClientData instanceData; /* The socket state. */
- int mask; /* Events of interest; an OR-ed
- * combination of TCL_READABLE,
- * TCL_WRITABLE and TCL_EXCEPTION. */
-{
- SocketInfo *infoPtr = (SocketInfo *) instanceData;
-
- /*
- * Update the watch events mask.
- */
-
- infoPtr->watchEvents = 0;
- if (mask & TCL_READABLE) {
- infoPtr->watchEvents |= (FD_READ|FD_CLOSE|FD_ACCEPT);
- }
- if (mask & TCL_WRITABLE) {
- infoPtr->watchEvents |= (FD_WRITE|FD_CONNECT);
- }
-
- /*
- * If there are any conditions already set, then tell the notifier to poll
- * rather than block.
- */
-
- if (infoPtr->readyEvents & infoPtr->watchEvents) {
- Tcl_Time blockTime = { 0, 0 };
- Tcl_SetMaxBlockTime(&blockTime);
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TcpGetProc --
- *
- * Called from Tcl_GetChannelHandle to retrieve an OS handle from inside
- * a TCP socket based channel.
- *
- * Results:
- * Returns TCL_OK with the socket in handlePtr.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-TcpGetHandleProc(instanceData, direction, handlePtr)
- ClientData instanceData; /* The socket state. */
- int direction; /* Not used. */
- ClientData *handlePtr; /* Where to store the handle. */
-{
- SocketInfo *statePtr = (SocketInfo *) instanceData;
-
- *handlePtr = (ClientData) statePtr->socket;
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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 = (ThreadSpecificData *)(arg);
-
- tsdPtr->hwnd = CreateWindowA("TclSocket", "TclSocket",
- WS_TILED, 0, 0, 0, 0, NULL, NULL, windowClass.hInstance, NULL);
-
- /*
- * Signal the main thread that the window has been created
- * and that the socket thread is ready to go.
- */
-
- SetEvent(tsdPtr->readyEvent);
-
- if (tsdPtr->hwnd == NULL) {
- return 1;
- } else {
- /*
- * store the tsdPtr, it's from a different thread, so it's
- * not directly accessible, but needed.
- */
-
-#ifdef _WIN64
- SetWindowLongPtr(tsdPtr->hwnd, GWLP_USERDATA, (LONG) tsdPtr);
-#else
- SetWindowLong(tsdPtr->hwnd, GWL_USERDATA, (LONG) tsdPtr);
-#endif
- }
-
- while (1) {
- /*
- * Process all outstanding messages on the socket window.
- */
-
- while (PeekMessage(&msg, tsdPtr->hwnd, 0, 0, PM_REMOVE)) {
- DispatchMessage(&msg);
- }
- WaitMessage();
- }
-}
-
-
-/*
- *----------------------------------------------------------------------
- *
- * 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, message, wParam, lParam)
- HWND hwnd;
- UINT message;
- WPARAM wParam;
- LPARAM lParam;
-{
- int event, error;
- SOCKET socket;
- SocketInfo *infoPtr;
- ThreadSpecificData *tsdPtr =
-#ifdef _WIN64
- (ThreadSpecificData *) GetWindowLongPtr(hwnd, GWLP_USERDATA);
-#else
- (ThreadSpecificData *) GetWindowLong(hwnd, GWL_USERDATA);
-#endif
-
- switch (message) {
-
- default:
- return DefWindowProc(hwnd, message, wParam, lParam);
- break;
-
- case SOCKET_MESSAGE:
- event = WSAGETSELECTEVENT(lParam);
- error = WSAGETSELECTERROR(lParam);
- socket = (SOCKET) wParam;
-
- /*
- * Find the specified socket on the socket list and update its
- * eventState flag.
- */
-
- WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
- for (infoPtr = tsdPtr->socketList; infoPtr != NULL;
- infoPtr = infoPtr->nextPtr) {
- if (infoPtr->socket == socket) {
- /*
- * 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 and
- * FD_ACCEPT.
- */
-
- if (event & FD_CLOSE) {
- infoPtr->acceptEventCount = 0;
- infoPtr->readyEvents &= ~(FD_WRITE|FD_ACCEPT);
- } else if (event & FD_ACCEPT) {
- infoPtr->acceptEventCount++;
- }
-
- if (event & FD_CONNECT) {
- /*
- * The socket is now connected,
- * clear the async connect flag.
- */
-
- infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT);
-
- /*
- * Remember any error that occurred so we can report
- * connection failures.
- */
-
- if (error != ERROR_SUCCESS) {
- TclWinConvertWSAError(error);
- infoPtr->lastError = Tcl_GetErrno();
- }
-
- }
- if(infoPtr->flags & SOCKET_ASYNC_CONNECT) {
- infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT);
- if (error != ERROR_SUCCESS) {
- TclWinConvertWSAError(error);
- infoPtr->lastError = Tcl_GetErrno();
- }
- infoPtr->readyEvents |= FD_WRITE;
- }
- infoPtr->readyEvents |= event;
-
- /*
- * Wake up the Main Thread.
- */
- SetEvent(tsdPtr->readyEvent);
- Tcl_ThreadAlert(tsdPtr->threadId);
- break;
- }
- }
- SetEvent(tsdPtr->socketListLock);
- break;
- case SOCKET_SELECT:
- infoPtr = (SocketInfo *) lParam;
- if (wParam == SELECT) {
-
- (void) (*winSock.WSAAsyncSelect)(infoPtr->socket, hwnd,
- SOCKET_MESSAGE, infoPtr->selectEvents);
- } else {
- /*
- * Clear the selection mask
- */
-
- (void) (*winSock.WSAAsyncSelect)(infoPtr->socket, hwnd, 0, 0);
- }
- break;
- case SOCKET_TERMINATE:
- ExitThread(0);
- break;
- }
-
- return 0;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-char *
-Tcl_GetHostName()
-{
- DWORD length;
- WCHAR wbuf[MAX_COMPUTERNAME_LENGTH + 1];
-
- Tcl_MutexLock(&socketMutex);
- InitSockets();
-
- if (hostnameInitialized) {
- Tcl_MutexUnlock(&socketMutex);
- return hostname;
- }
- Tcl_MutexUnlock(&socketMutex);
-
- if (TclpHasSockets(NULL) == TCL_OK) {
- /*
- * INTL: bug
- */
-
- if ((*winSock.gethostname)(hostname, sizeof(hostname)) == 0) {
- Tcl_MutexLock(&socketMutex);
- hostnameInitialized = 1;
- Tcl_MutexUnlock(&socketMutex);
- return hostname;
- }
- }
- Tcl_MutexLock(&socketMutex);
- length = sizeof(hostname);
- if ((*tclWinProcs->getComputerNameProc)(wbuf, &length) != 0) {
- /*
- * Convert string from native to UTF then change to lowercase.
- */
-
- Tcl_DString ds;
-
- lstrcpynA(hostname, Tcl_WinTCharToUtf((TCHAR *) wbuf, -1, &ds),
- sizeof(hostname));
- Tcl_DStringFree(&ds);
- Tcl_UtfToLower(hostname);
- } else {
- hostname[0] = '\0';
- }
- hostnameInitialized = 1;
- Tcl_MutexUnlock(&socketMutex);
- return hostname;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclWinGetSockOpt, et al. --
- *
- * These functions are wrappers that let us bind the WinSock
- * API dynamically so we can run on systems that don't have
- * the wsock32.dll. We need wrappers for these interfaces
- * because they are called from the generic Tcl code.
- *
- * Results:
- * As defined for each function.
- *
- * Side effects:
- * As defined for each function.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclWinGetSockOpt(SOCKET s, int level, int optname, char * optval,
- int FAR *optlen)
-{
- /*
- * 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 SOCKET_ERROR;
- }
-
- return (*winSock.getsockopt)(s, level, optname, optval, optlen);
-}
-
-int
-TclWinSetSockOpt(SOCKET s, int level, int optname, const char * optval,
- int optlen)
-{
- /*
- * 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 SOCKET_ERROR;
- }
-
- return (*winSock.setsockopt)(s, level, optname, optval, optlen);
-}
-
-u_short
-TclWinNToHS(u_short netshort)
-{
- /*
- * 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 (u_short) -1;
- }
-
- return (*winSock.ntohs)(netshort);
-}
-
-struct servent *
-TclWinGetServByName(const char * name, const char * proto)
-{
- /*
- * 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 (struct servent *) NULL;
- }
-
- return (*winSock.getservbyname)(name, proto);
-}
-
-
diff --git a/win/tclWinTest.c b/win/tclWinTest.c
deleted file mode 100644
index 07f198b..0000000
--- a/win/tclWinTest.c
+++ /dev/null
@@ -1,190 +0,0 @@
-/*
- * 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.
- *
- * RCS: @(#) $Id: tclWinTest.c,v 1.4 1999/10/29 03:05:13 hobbs Exp $
- */
-
-#include "tclWinInt.h"
-
-/*
- * Forward declarations of procedures defined later in this file:
- */
-int TclplatformtestInit _ANSI_ARGS_((Tcl_Interp *interp));
-static int TesteventloopCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int argc, char **argv));
-static int TestvolumetypeCmd _ANSI_ARGS_((ClientData dummy,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
-
-/*
- *----------------------------------------------------------------------
- *
- * TclplatformtestInit --
- *
- * Defines commands that test platform specific functionality for
- * Unix platforms.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * Defines new commands.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclplatformtestInit(interp)
- Tcl_Interp *interp; /* Interpreter to add commands to. */
-{
- /*
- * Add commands for platform specific tests for Windows here.
- */
-
- Tcl_CreateCommand(interp, "testeventloop", TesteventloopCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateObjCommand(interp, "testvolumetype", TestvolumetypeCmd,
- (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TesteventloopCmd --
- *
- * This procedure 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, interp, argc, argv)
- ClientData clientData; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
-{
- static int *framePtr = NULL; /* Pointer to integer on stack frame of
- * innermost invocation of the "wait"
- * subcommand. */
-
- if (argc < 2) {
- Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
- " option ... \"", (char *) NULL);
- return TCL_ERROR;
- }
- if (strcmp(argv[1], "done") == 0) {
- *framePtr = 1;
- } else if (strcmp(argv[1], "wait") == 0) {
- int *oldFramePtr;
- int done;
- MSG msg;
- 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) {
- if (!GetMessage(&msg, NULL, 0, 0)) {
- /*
- * The application is exiting, so repost the quit message
- * and start unwinding.
- */
-
- PostQuitMessage(msg.wParam);
- break;
- }
- TranslateMessage(&msg);
- DispatchMessage(&msg);
- }
- (void) Tcl_SetServiceMode(oldMode);
- framePtr = oldFramePtr;
- } else {
- Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": must be done or wait", (char *) NULL);
- return TCL_ERROR;
- }
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Testvolumetype --
- *
- * This procedure 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, interp, objc, objv)
- 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];
- 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:""), "\"", (char *) NULL);
- TclWinConvertError(GetLastError());
- return TCL_ERROR;
- }
- Tcl_SetResult(interp, volType, TCL_VOLATILE);
- return TCL_OK;
-#undef VOL_BUF_SIZE
-}
diff --git a/win/tclWinThrd.c b/win/tclWinThrd.c
deleted file mode 100644
index 8fe2596..0000000
--- a/win/tclWinThrd.c
+++ /dev/null
@@ -1,903 +0,0 @@
-/*
- * tclWinThread.c --
- *
- * This file implements the Windows-specific thread operations.
- *
- * Copyright (c) 1998 by Sun Microsystems, Inc.
- * Copyright (c) 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.
- *
- * RCS: @(#) $Id: tclWinThrd.c,v 1.8 2000/04/20 01:30:20 hobbs Exp $
- */
-
-#include "tclWinInt.h"
-
-#include <dos.h>
-#include <fcntl.h>
-#include <io.h>
-#include <sys/stat.h>
-
-/*
- * This is the master lock used to serialize access to other
- * serialization data structures.
- */
-
-static CRITICAL_SECTION masterLock;
-static int init = 0;
-#define MASTER_LOCK EnterCriticalSection(&masterLock)
-#define MASTER_UNLOCK LeaveCriticalSection(&masterLock)
-
-/*
- * 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.
- */
-
-static CRITICAL_SECTION allocLock;
-static Tcl_Mutex allocLockPtr = (Tcl_Mutex) &allocLock;
-
-/*
- * 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.
- */
-
-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;
-
-/*
- * 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.
- * WIN_THREAD_DEAD Dying - no per-thread event anymore.
- */
-
-#define WIN_THREAD_UNINIT 0x0
-#define WIN_THREAD_RUNNING 0x1
-#define WIN_THREAD_BLOCKED 0x2
-#define WIN_THREAD_DEAD 0x4
-
-/*
- * The per condition queue pointers and the
- * Mutex used to serialize access to the queue.
- */
-
-typedef struct WinCondition {
- CRITICAL_SECTION condLock; /* Lock to serialize queuing on the condition */
- struct ThreadSpecificData *firstPtr; /* Queue pointers */
- struct ThreadSpecificData *lastPtr;
-} WinCondition;
-
-static void FinalizeConditionEvent(ClientData data);
-
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_CreateThread --
- *
- * 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
-Tcl_CreateThread(idPtr, proc, clientData, stackSize, flags)
- 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 */
-{
- unsigned long code;
-
- code = _beginthreadex(NULL, stackSize, proc, clientData, 0,
- (unsigned *)idPtr);
- if (code == 0) {
- return TCL_ERROR;
- } else {
- return TCL_OK;
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclpThreadExit --
- *
- * This procedure terminates the current thread.
- *
- * Results:
- * None.
- *
- * Side effects:
- * This procedure terminates the current thread.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclpThreadExit(status)
- int status;
-{
- _endthreadex((DWORD)status);
-}
-
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_GetCurrentThread --
- *
- * This procedure returns the ID of the currently running thread.
- *
- * Results:
- * A thread ID.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_ThreadId
-Tcl_GetCurrentThread()
-{
- return (Tcl_ThreadId)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()
-{
- if (!init) {
- /*
- * 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.
- */
- init = 1;
- 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()
-{
- 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()
-{
- if (!init) {
- /*
- * 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.
- */
- init = 1;
- InitializeCriticalSection(&initLock);
- InitializeCriticalSection(&masterLock);
- }
- EnterCriticalSection(&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()
-{
-#ifdef TCL_THREADS
- InitializeCriticalSection(&allocLock);
- return &allocLockPtr;
-#else
- return NULL;
-#endif
-}
-
-
-#ifdef TCL_THREADS
-/*
- *----------------------------------------------------------------------
- *
- * 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()
-{
- LeaveCriticalSection(&masterLock);
-}
-
-
-/*
- *----------------------------------------------------------------------
- *
- * 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(mutexPtr)
- Tcl_Mutex *mutexPtr; /* The lock */
-{
- CRITICAL_SECTION *csPtr;
- if (*mutexPtr == NULL) {
- MASTER_LOCK;
-
- /*
- * Double inside master lock check to avoid a race.
- */
-
- if (*mutexPtr == NULL) {
- csPtr = (CRITICAL_SECTION *)ckalloc(sizeof(CRITICAL_SECTION));
- InitializeCriticalSection(csPtr);
- *mutexPtr = (Tcl_Mutex)csPtr;
- TclRememberMutex(mutexPtr);
- }
- MASTER_UNLOCK;
- }
- 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(mutexPtr)
- 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(mutexPtr)
- Tcl_Mutex *mutexPtr;
-{
- CRITICAL_SECTION *csPtr = *(CRITICAL_SECTION **)mutexPtr;
- if (csPtr != NULL) {
- ckfree((char *)csPtr);
- *mutexPtr = NULL;
- }
-}
-
-
-/*
- *----------------------------------------------------------------------
- *
- * TclpThreadDataKeyInit --
- *
- * This procedure initializes a thread specific data block key.
- * Each thread has table of pointers to thread specific data.
- * all threads agree on which table entry is used by each module.
- * this is remembered in a "data key", that is just an index into
- * this table. To allow self initialization, the interface
- * passes a pointer to this key and the first thread to use
- * the key fills in the pointer to the key. The key should be
- * a process-wide static.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Will allocate memory the first time this process calls for
- * this key. In this case it modifies its argument
- * to hold the pointer to information about the key.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclpThreadDataKeyInit(keyPtr)
- Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk,
- * really (DWORD **) */
-{
- DWORD *indexPtr;
-
- MASTER_LOCK;
- if (*keyPtr == NULL) {
- indexPtr = (DWORD *)ckalloc(sizeof(DWORD));
- *indexPtr = TlsAlloc();
- *keyPtr = (Tcl_ThreadDataKey)indexPtr;
- TclRememberDataKey(keyPtr);
- }
- MASTER_UNLOCK;
-}
-
-
-/*
- *----------------------------------------------------------------------
- *
- * TclpThreadDataKeyGet --
- *
- * This procedure returns a pointer to a block of thread local storage.
- *
- * Results:
- * A thread-specific pointer to the data structure, or NULL
- * if the memory has not been assigned to this key for this thread.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-VOID *
-TclpThreadDataKeyGet(keyPtr)
- Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk,
- * really (DWORD **) */
-{
- DWORD *indexPtr = *(DWORD **)keyPtr;
- if (indexPtr == NULL) {
- return NULL;
- } else {
- return (VOID *) TlsGetValue(*indexPtr);
- }
-}
-
-
-/*
- *----------------------------------------------------------------------
- *
- * TclpThreadDataKeySet --
- *
- * This procedure sets the pointer to a block of thread local storage.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Sets up the thread so future calls to TclpThreadDataKeyGet with
- * this key will return the data pointer.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclpThreadDataKeySet(keyPtr, data)
- Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk,
- * really (pthread_key_t **) */
- VOID *data; /* Thread local storage */
-{
- DWORD *indexPtr = *(DWORD **)keyPtr;
- TlsSetValue(*indexPtr, (void *)data);
-}
-
-
-/*
- *----------------------------------------------------------------------
- *
- * TclpFinalizeThreadData --
- *
- * This procedure cleans up the thread-local storage. This is
- * called once for each thread.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Frees up the memory.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclpFinalizeThreadData(keyPtr)
- Tcl_ThreadDataKey *keyPtr;
-{
- VOID *result;
- DWORD *indexPtr;
-
- if (*keyPtr != NULL) {
- indexPtr = *(DWORD **)keyPtr;
- result = (VOID *)TlsGetValue(*indexPtr);
- if (result != NULL) {
- ckfree((char *)result);
- TlsSetValue(*indexPtr, (void *)NULL);
- }
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclpFinalizeThreadDataKey --
- *
- * This procedure is invoked to clean up one key. This is a
- * process-wide storage identifier. The thread finalization code
- * cleans up the thread local storage itself.
- *
- * This assumes the master lock is held.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The key is deallocated.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclpFinalizeThreadDataKey(keyPtr)
- Tcl_ThreadDataKey *keyPtr;
-{
- DWORD *indexPtr;
- if (*keyPtr != NULL) {
- indexPtr = *(DWORD **)keyPtr;
- TlsFree(*indexPtr);
- ckfree((char *)indexPtr);
- *keyPtr = NULL;
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_ConditionWait --
- *
- * This procedure is invoked to wait on a condition variable.
- * The mutex is automically 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(condPtr, mutexPtr, timePtr)
- Tcl_Condition *condPtr; /* Really (WinCondition **) */
- Tcl_Mutex *mutexPtr; /* Really (CRITICAL_SECTION **) */
- 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);
-
- if (tsdPtr->flags & WIN_THREAD_DEAD) {
- /*
- * No more per-thread event on which to wait.
- */
-
- return;
- }
-
- /*
- * Self initialize the two parts of the contition.
- * The per-condition and per-thread parts need to be
- * handled independently.
- */
-
- if (tsdPtr->flags == WIN_THREAD_UNINIT) {
- MASTER_LOCK;
-
- /*
- * 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;
- }
- MASTER_UNLOCK;
-
- if (doExit) {
- /*
- * Create a per-thread exit handler to clean up the condEvent.
- * We must be careful do 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,
- (ClientData) tsdPtr);
- }
- }
-
- if (*condPtr == NULL) {
- MASTER_LOCK;
-
- /*
- * Initialize the per-condition queue pointers and Mutex.
- */
-
- if (*condPtr == NULL) {
- winCondPtr = (WinCondition *)ckalloc(sizeof(WinCondition));
- InitializeCriticalSection(&winCondPtr->condLock);
- winCondPtr->firstPtr = NULL;
- winCondPtr->lastPtr = NULL;
- *condPtr = (Tcl_Condition)winCondPtr;
- TclRememberCondition(condPtr);
- }
- MASTER_UNLOCK;
- }
- 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 (WaitForSingleObject(tsdPtr->condEvent, wtime) == WAIT_TIMEOUT) {
- timeout = 1;
- }
- EnterCriticalSection(&winCondPtr->condLock);
- }
-
- /*
- * Be careful on timeouts because the signal might arrive right around
- * time 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(condPtr)
- Tcl_Condition *condPtr;
-{
- WinCondition *winCondPtr;
- ThreadSpecificData *tsdPtr;
- if (condPtr != NULL) {
- winCondPtr = *((WinCondition **)condPtr);
-
- /*
- * 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 {
- /*
- * Noone 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(data)
- ClientData data;
-{
- ThreadSpecificData *tsdPtr = (ThreadSpecificData *)data;
- tsdPtr->flags = WIN_THREAD_DEAD;
- 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(condPtr)
- 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) {
- ckfree((char *)winCondPtr);
- *condPtr = NULL;
- }
-}
-#endif /* TCL_THREADS */
diff --git a/win/tclWinThrd.h b/win/tclWinThrd.h
deleted file mode 100644
index 2572d1b..0000000
--- a/win/tclWinThrd.h
+++ /dev/null
@@ -1,21 +0,0 @@
-/*
- * tclWinThrd.h --
- *
- * This header file defines things for thread support.
- *
- * Copyright (c) 1998 Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * SCCS: @(#) tclWinThrd.h 1.2 98/01/27 11:48:05
- */
-
-#ifndef _TCLWINTHRD
-#define _TCLWINTHRD
-
-#ifdef TCL_THREADS
-
-#endif /* TCL_THREADS */
-
-#endif /* _TCLWINTHRD */
diff --git a/win/tclWinTime.c b/win/tclWinTime.c
deleted file mode 100644
index db2affd..0000000
--- a/win/tclWinTime.c
+++ /dev/null
@@ -1,442 +0,0 @@
-/*
- * 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.
- *
- * RCS: @(#) $Id: tclWinTime.c,v 1.5 1999/12/01 00:08:43 hobbs Exp $
- */
-
-#include "tclWinInt.h"
-
-#define SECSPERDAY (60L * 60L * 24L)
-#define SECSPERYEAR (SECSPERDAY * 365L)
-#define SECSPER4YEAR (SECSPERYEAR * 4L + SECSPERDAY)
-
-/*
- * The following arrays contain the day of year for the last day of
- * each month, where index 1 is January.
- */
-
-static int normalDays[] = {
- -1, 30, 58, 89, 119, 150, 180, 211, 242, 272, 303, 333, 364
-};
-
-static int leapDays[] = {
- -1, 30, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365
-};
-
-typedef struct ThreadSpecificData {
- char tzName[64]; /* Time zone name */
- struct tm tm; /* time information */
-} ThreadSpecificData;
-static Tcl_ThreadDataKey dataKey;
-
-/*
- * Declarations for functions defined later in this file.
- */
-
-static struct tm * ComputeGMT _ANSI_ARGS_((const time_t *tp));
-
-/*
- *----------------------------------------------------------------------
- *
- * 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()
-{
- return (unsigned long) time((time_t *) NULL);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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()
-{
- return GetTickCount();
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclpGetTimeZone --
- *
- * Determines the current timezone. The method varies wildly
- * between different Platform implementations, so its hidden in
- * this function.
- *
- * Results:
- * Minutes west of GMT.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclpGetTimeZone (currentTime)
- unsigned long currentTime;
-{
- int timeZone;
-
- tzset();
- timeZone = _timezone / 60;
-
- return timeZone;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclpGetTime --
- *
- * 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:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclpGetTime(timePtr)
- Tcl_Time *timePtr; /* Location to store time information. */
-{
- struct timeb t;
-
- ftime(&t);
- timePtr->sec = t.time;
- timePtr->usec = t.millitm * 1000;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclpGetTZName --
- *
- * Gets the current timezone string.
- *
- * Results:
- * Returns a pointer to a static string, or NULL on failure.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-char *
-TclpGetTZName(int dst)
-{
- int len;
- char *zone, *p;
- TIME_ZONE_INFORMATION tz;
- Tcl_Encoding encoding;
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- char *name = tsdPtr->tzName;
-
- /*
- * tzset() under Borland doesn't seem to set up tzname[] at all.
- * tzset() under MSVC has the following weird observed behavior:
- * First time we call "clock format [clock seconds] -format %Z -gmt 1"
- * we get "GMT", but on all subsequent calls we get the current time
- * zone string, even though env(TZ) is GMT and the variable _timezone
- * is 0.
- */
-
- name[0] = '\0';
-
- zone = getenv("TZ");
- if (zone != NULL) {
- /*
- * TZ is of form "NST-4:30NDT", where "NST" would be the
- * name of the standard time zone for this area, "-4:30" is
- * the offset from GMT in hours, and "NDT is the name of
- * the daylight savings time zone in this area. The offset
- * and DST strings are optional.
- */
-
- len = strlen(zone);
- if (len > 3) {
- len = 3;
- }
- if (dst != 0) {
- /*
- * Skip the offset string and get the DST string.
- */
-
- p = zone + len;
- p += strspn(p, "+-:0123456789");
- if (*p != '\0') {
- zone = p;
- len = strlen(zone);
- if (len > 3) {
- len = 3;
- }
- }
- }
- Tcl_ExternalToUtf(NULL, NULL, zone, len, 0, NULL, name,
- sizeof(tsdPtr->tzName), NULL, NULL, NULL);
- }
- if (name[0] == '\0') {
- if (GetTimeZoneInformation(&tz) == TIME_ZONE_ID_UNKNOWN) {
- /*
- * MSDN: On NT this is returned if DST is not used in
- * the current TZ
- */
- dst = 0;
- }
- encoding = Tcl_GetEncoding(NULL, "unicode");
- Tcl_ExternalToUtf(NULL, encoding,
- (char *) ((dst) ? tz.DaylightName : tz.StandardName), -1,
- 0, NULL, name, sizeof(tsdPtr->tzName), NULL, NULL, NULL);
- Tcl_FreeEncoding(encoding);
- }
- return name;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclpGetDate --
- *
- * This function converts between seconds and struct tm. If
- * useGMT is 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(t, useGMT)
- TclpTime_t t;
- int useGMT;
-{
- const time_t *tp = (const time_t *) t;
- struct tm *tmPtr;
- long 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.
- */
-
- if (*tp >= 0) {
- return localtime(tp);
- }
-
- time = *tp - _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 (*tp < (LONG_MAX - 2 * SECSPERDAY)
- && *tp > (LONG_MIN + 2 * SECSPERDAY)) {
- tmPtr = ComputeGMT(&time);
- } else {
- tmPtr = ComputeGMT(tp);
-
- 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 += time;
- tmPtr->tm_yday += time;
- tmPtr->tm_wday = (tmPtr->tm_wday + time) % 7;
- }
- } else {
- tmPtr = ComputeGMT(tp);
- }
- 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(tp)
- const time_t *tp;
-{
- struct tm *tmPtr;
- long tmp, rem;
- int isLeap;
- int *days;
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
-
- tmPtr = &tsdPtr->tm;
-
- /*
- * Compute the 4 year span containing the specified time.
- */
-
- tmp = *tp / SECSPER4YEAR;
- rem = *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++) {
- }
- tmPtr->tm_mon = --tmp;
- tmPtr->tm_mday = tmPtr->tm_yday - days[tmp];
-
- /*
- * Compute day of week. Epoch started on a Thursday.
- */
-
- tmPtr->tm_wday = (*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;
-}
diff --git a/win/tclsh.ico b/win/tclsh.ico
deleted file mode 100644
index 8bcaf48..0000000
--- a/win/tclsh.ico
+++ /dev/null
Binary files differ
diff --git a/win/tclsh.rc b/win/tclsh.rc
deleted file mode 100644
index 874abd7..0000000
--- a/win/tclsh.rc
+++ /dev/null
@@ -1,46 +0,0 @@
-// RCS: @(#) $Id: tclsh.rc,v 1.5 2000/04/18 23:26:45 redman Exp $
-//
-// Version
-//
-
-#define VS_VERSION_INFO 1
-
-#define RESOURCE_INCLUDED
-#include <tcl.h>
-
-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
- FILEFLAGS 0x0L
- FILEOS 0x4 /* VOS__WINDOWS32 */
- FILETYPE 0x2 /* VFT_DLL */
- 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) ".exe\0"
- VALUE "CompanyName", "Scriptics Corporation\0"
- VALUE "FileVersion", TCL_PATCH_LEVEL
- VALUE "LegalCopyright", "Copyright (c) 2000 by Scriptics Corporation\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"
-