diff options
author | cvs2fossil <cvs2fossil> | 2000-08-08 19:03:31 (GMT) |
---|---|---|
committer | cvs2fossil <cvs2fossil> | 2000-08-08 19:03:31 (GMT) |
commit | 45a4a0c600cf1445c9d027e479fbd935e036b8e1 (patch) | |
tree | bf3e807b918a716744437d65e496366d98e8df0c /win | |
parent | a4d73ade8b0addef3a4e1244caa4dcfbf69d9241 (diff) | |
download | tcl-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')
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(¬ifierMutex); - if (notifierCount == 0) { - class.style = 0; - class.cbClsExtra = 0; - class.cbWndExtra = 0; - class.hInstance = TclWinGetTclInstance(); - class.hbrBackground = NULL; - class.lpszMenuName = NULL; - class.lpszClassName = "TclNotifier"; - class.lpfnWndProc = NotifierProc; - class.hIcon = NULL; - class.hCursor = NULL; - - if (!RegisterClassA(&class)) { - panic("Unable to register TclNotifier window class"); - } - } - notifierCount++; - Tcl_MutexUnlock(¬ifierMutex); - - tsdPtr->pending = 0; - tsdPtr->timerActive = 0; - - InitializeCriticalSection(&tsdPtr->crit); - - tsdPtr->hwnd = NULL; - tsdPtr->thread = GetCurrentThreadId(); - tsdPtr->event = CreateEvent(NULL, TRUE /* manual */, - FALSE /* !signaled */, NULL); - - return (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(¬ifierMutex); - notifierCount--; - if (notifierCount == 0) { - UnregisterClassA("TclNotifier", TclWinGetTclInstance()); - } - Tcl_MutexUnlock(¬ifierMutex); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_AlertNotifier -- - * - * Wake up the specified notifier from any thread. This routine - * is called by the platform independent notifier code whenever - * the Tcl_ThreadAlert routine is called. This routine is - * guaranteed not to be called on a given notifier after - * Tcl_FinalizeNotifier is called for that notifier. This routine - * is typically called from a thread other than the notifier's - * thread. - * - * Results: - * None. - * - * Side effects: - * Sends a message to the messaging window for the notifier - * if there isn't already one pending. - * - *---------------------------------------------------------------------- - */ - -void -Tcl_AlertNotifier(clientData) - ClientData 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 Binary files differdeleted file mode 100644 index 8bcaf48..0000000 --- a/win/tclsh.ico +++ /dev/null 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" - |