summaryrefslogtreecommitdiffstats
path: root/win
diff options
context:
space:
mode:
authorrjohnson <rjohnson>1998-03-26 14:56:55 (GMT)
committerrjohnson <rjohnson>1998-03-26 14:56:55 (GMT)
commit72d823b9193f9ee2b0318563b49363cd08c11f24 (patch)
treec168cc164a71f320db9dcdfe7518ba7bd0d2c8d9 /win
parent2b5738da524e944cda39e24c0a87b745a43bd8c3 (diff)
downloadtcl-72d823b9193f9ee2b0318563b49363cd08c11f24.zip
tcl-72d823b9193f9ee2b0318563b49363cd08c11f24.tar.gz
tcl-72d823b9193f9ee2b0318563b49363cd08c11f24.tar.bz2
Initial revision
Diffstat (limited to 'win')
-rw-r--r--win/README109
-rw-r--r--win/cat.c37
-rw-r--r--win/makefile.bc387
-rw-r--r--win/makefile.vc377
-rw-r--r--win/pkgIndex.tcl11
-rw-r--r--win/stub16.c198
-rw-r--r--win/tcl.rc42
-rw-r--r--win/tcl16.rc37
-rw-r--r--win/tclAppInit.c259
-rw-r--r--win/tclWin16.c347
-rw-r--r--win/tclWin32Dll.c362
-rw-r--r--win/tclWinChan.c1185
-rw-r--r--win/tclWinError.c393
-rw-r--r--win/tclWinFCmd.c1401
-rw-r--r--win/tclWinFile.c647
-rw-r--r--win/tclWinInit.c394
-rw-r--r--win/tclWinInt.h38
-rw-r--r--win/tclWinLoad.c114
-rw-r--r--win/tclWinMtherr.c61
-rw-r--r--win/tclWinNotify.c325
-rw-r--r--win/tclWinPipe.c2470
-rw-r--r--win/tclWinPort.h399
-rw-r--r--win/tclWinReg.c1212
-rw-r--r--win/tclWinSock.c2113
-rw-r--r--win/tclWinTest.c130
-rw-r--r--win/tclWinTime.c373
-rw-r--r--win/tclsh.rc36
-rw-r--r--win/winDumpExts.c503
28 files changed, 13960 insertions, 0 deletions
diff --git a/win/README b/win/README
new file mode 100644
index 0000000..0e3550b
--- /dev/null
+++ b/win/README
@@ -0,0 +1,109 @@
+Tcl 8.0p2 for Windows
+
+by Scott Stanton
+Sun Microsystems Laboratories
+scott.stanton@eng.sun.com
+
+SCCS: @(#) README 1.25 97/11/21 15:15:40
+
+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 rest of this file
+contains information specific to the Windows version of Tcl.
+
+2. Distribution notes
+---------------------
+
+Tcl 8.0 for Windows is distributed in binary form in addition to the
+common source release. The binary distribution is a self-extracting
+archive with a built-in installation script.
+
+Look for the binary release in the same location as the source release
+(ftp.smli.com:/pub/tcl or any of the mirror sites). For most users,
+the binary release will be much easier to install and use. You only
+need the source release if you plan to modify the core of Tcl, or if
+you need to compile with a different compiler. With the addition of
+the dynamic loading interface, it is no longer necessary to have the
+source distribution in order to build and use extensions.
+
+3. Compiling Tcl
+----------------
+
+In order to compile Tcl for Windows, you need the following items:
+
+ Tcl 8.0 Source Distribution (plus any patches)
+
+ Borland C++ 4.52 (both 16-bit and 32-bit compilers)
+ or
+ Visual C++ 2.x/4.x
+ Visual C++ 1.5 (to build tcl1680.dll for Win32s support of exec)
+
+In the "win" subdirectory of the source release, you will find two
+files called "makefile.bc" and "makefile.vc". These are the makefiles
+for the Borland and Visual C++ compilers respectively. You should
+copy the appropriate one to "makefile" and 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 three places for the library files:
+
+ 1) The path specified in the environment variable "TCL_LIBRARY".
+
+ 2) In the lib\tcl8.0 directory under the installation directory
+ as specified in the registry:
+
+ For Windows NT & 95:
+ HKEY_LOCAL_MACHINE\SOFTWARE\Sun\Tcl\8.0
+ Value Name is "Root"
+
+ For Win32s:
+ HKEY_CLASSES_ROOT\SOFTWARE\Sun\Tcl\8.0\
+
+ 3) Relative to the directory containing the current .exe.
+ Tcl will look for a directory "..\lib\tcl8.0" relative to the
+ directory containing the currently running .exe.
+
+Note that in order to run tclsh80.exe, you must ensure that tcl80.dll
+and tclpip80.dll (plus tcl1680.dll under Win32s) are on your path, in
+the system directory, or in the directory containing tclsh80.exe.
+
+4. 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.
+
+In order to run the test suite, you build the "test" target using the
+appropriate makefile for your compiler.
+
+
+5. Known Bugs
+-------------
+
+Here is the current list of known bugs/missing features for the
+Windows version of Tcl:
+
+- Blocking "after" commands (e.g. "after 3000") don't work on Win32s.
+- Clock command fails to handle daylight savings time boundaries for
+ things like "last week".
+- Background processes aren't properly detached on NT.
+- File events only work on sockets.
+- Pipes/files/console/serial ports don't support nonblocking I/O.
+- The library cannot be used by two processes at the same time under
+ Win32s.
+
+If you have comments or bug reports for the Windows version of Tcl,
+please direct them to:
+
+Scott Stanton
+scott.stanton@eng.sun.com
+
+or post them to the comp.lang.tcl newsgroup.
diff --git a/win/cat.c b/win/cat.c
new file mode 100644
index 0000000..0ce550f
--- /dev/null
+++ b/win/cat.c
@@ -0,0 +1,37 @@
+/*
+ * 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.
+ *
+ * SCCS: @(#) cat.c 1.3 96/09/18 15:15:32
+ */
+
+#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/makefile.bc b/win/makefile.bc
new file mode 100644
index 0000000..c0c9740
--- /dev/null
+++ b/win/makefile.bc
@@ -0,0 +1,387 @@
+# Copyright (c) 1995-1996 Sun Microsystems, Inc.
+# SCCS: @(#) makefile.bc 1.82 97/11/20 15:52:39
+#
+# Borland C++ 4.5 makefile
+#
+
+#
+# Project directories
+#
+# ROOT = top of source tree
+# TMPDIR = location where .obj files should be stored during build
+# TOOLS = location of compiler and other development tools
+#
+
+ROOT = ..
+TMPDIR = .
+TOOLS = c:\bc45
+
+# uncomment the following line to compile with symbols
+#DEBUG=1
+
+# uncomment one of the following lines to compile with TCL_MEM_DEBUG,
+# TCL_COMPILE_DEBUG, or TCL_COMPILE_STATS
+#DEBUGDEFINES =TCL_MEM_DEBUG
+#DEBUGDEFINES =TCL_MEM_DEBUG;TCL_COMPILE_DEBUG
+#DEBUGDEFINES =TCL_MEM_DEBUG;TCL_COMPILE_STATS
+#DEBUGDEFINES =TCL_MEM_DEBUG;TCL_COMPILE_DEBUG;TCL_COMPILE_STATS
+
+
+######################################################################
+# Do not modify below this line
+######################################################################
+
+STACKSIZE = 1f0001
+
+VERSION = 80
+
+TCLLIB = tcl$(VERSION).lib
+TCLDLL = tcl$(VERSION).dll
+TCL16DLL = tcl16$(VERSION).dll
+TCLSH = tclsh$(VERSION).exe
+TCLTEST = tcltest.exe
+DUMPEXTS = dumpexts.exe
+TCLPIPEDLL = tclpip$(VERSION).dll
+TCLREGDLL = tclreg$(VERSION).dll
+CAT16 = cat16.exe
+CAT32 = cat32.exe
+
+TCLSHOBJS = \
+ $(TMPDIR)\tclAppInit.obj
+
+TCLTESTOBJS = \
+ $(TMPDIR)\tclTest.obj \
+ $(TMPDIR)\tclTestObj.obj \
+ $(TMPDIR)\tclWinTest.obj \
+ $(TMPDIR)\testMain.obj
+
+TCLOBJS = \
+ $(TMPDIR)\panic.obj \
+ $(TMPDIR)\regexp.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)\tclCompExpr.obj \
+ $(TMPDIR)\tclCompile.obj \
+ $(TMPDIR)\tclDate.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)\tclIOSock.obj \
+ $(TMPDIR)\tclIOUtil.obj \
+ $(TMPDIR)\tclLink.obj \
+ $(TMPDIR)\tclListObj.obj \
+ $(TMPDIR)\tclLoad.obj \
+ $(TMPDIR)\tclMain.obj \
+ $(TMPDIR)\tclNamesp.obj \
+ $(TMPDIR)\tclNotify.obj \
+ $(TMPDIR)\tclObj.obj \
+ $(TMPDIR)\tclParse.obj \
+ $(TMPDIR)\tclPipe.obj \
+ $(TMPDIR)\tclPkg.obj \
+ $(TMPDIR)\tclPosixStr.obj \
+ $(TMPDIR)\tclPreserve.obj \
+ $(TMPDIR)\tclProc.obj \
+ $(TMPDIR)\tclStringObj.obj \
+ $(TMPDIR)\tclTimer.obj \
+ $(TMPDIR)\tclUtil.obj \
+ $(TMPDIR)\tclVar.obj \
+ $(TMPDIR)\tclWin32Dll.obj \
+ $(TMPDIR)\tclWinChan.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)\tclWinTime.obj
+
+cc32 = $(TOOLS)\bin\bcc32.exe
+link32 = $(TOOLS)\bin\tlink32.exe
+rc32 = $(TOOLS)\bin\brcc32.exe
+implib = $(TOOLS)\bin\implib.exe
+
+cc16 = $(TOOLS)\bin\bcc.exe
+link16 = $(TOOLS)\bin\tlink.exe
+rc16 = $(TOOLS)\bin\brcc32.exe -31
+
+CP = copy
+RM = del
+
+WINDIR = $(ROOT)\win
+GENERICDIR = $(ROOT)\generic
+
+INCLUDES = $(TOOLS)\include;$(WINDIR);$(GENERICDIR)
+LIBDIRS = $(TOOLS)\lib;$(WINDIR)
+
+CON_CFLAGS = +cfgexe.cfg -WC
+TEST_CFLAGS = +cfgtest.cfg
+DLL16_CFLAGS = $(PROJECTCCFLAGS) -I$(INCLUDES) -D$(DEFINES) -WD -ml -c \
+ -3 -d -w
+TCL_CFLAGS = +cfgdll.cfg
+
+CON_LFLAGS = -Tpe -ap -c $(DEBUGLDFLAGS) $(TOOLS)\lib\c0x32
+DLL_LFLAGS = -Tpd -aa -c $(DEBUGLDFLAGS) $(TOOLS)\lib\c0d32
+GUI_LFLAGS = -Tpe -aa -c $(DEBUGLDFLAGS) $(TOOLS)\lib\c0w32
+DLL16_LFLAGS = -Twd -c -C -A=16 $(DEBUGLDFLAGS16) $(TOOLS)\lib\c0dl
+
+DLL_LIBS = import32 cw32mti
+CON_LIBS = $(TCLLIB) import32 cw32mti
+DLL16_LIBS = import cwl
+
+!ifndef DEBUG
+
+# these macros cause maximum optimization and no symbols
+DEBUGLDFLAGS =
+DEBUGCCFLAGS = -v- -vi- -O2
+DEBUGLDFLAGS16 = -Oc -Oi -Oa -Or
+!else
+
+# these macros enable debugging
+DEBUGLDFLAGS = -v
+DEBUGCCFLAGS = -k -Od -v
+DEBUGLDFLAGS16 =
+
+!endif
+
+DEFINES = MT;_RTLDLL;$(DEBUGDEFINES)
+PROJECTCCFLAGS = $(DEBUGCCFLAGS) -w-par -w-stu
+
+
+#
+# Global makefile settings
+#
+
+.AUTODEPEND
+.CACHEAUTODEPEND
+
+.suffixes:
+
+#.path.c=$(ROOT)\win;$(ROOT)\generic;$(ROOT)\compat
+#.path.obj=$(TMPDIR)
+#.path.dll=$(ROOT)\win
+
+#
+# Targets
+#
+
+release: $(TCLSH) dlls
+all: $(TCLSH) dlls $(CAT16) $(CAT32)
+tcltest: $(TCLTEST) dlls $(CAT16) $(CAT32)
+dlls: $(TCL16DLL) $(TCLPIPEDLL) $(TCLREGDLL)
+
+test: tcltest
+ $(TCLTEST) &&|
+ cd ../tests
+ source all
+|
+
+
+$(DUMPEXTS): cfgexe.cfg $(WINDIR)\winDumpExts.c
+ $(cc32) $(CON_CFLAGS) $(WINDIR)\winDumpExts.c
+ $(link32) $(CON_LFLAGS) \
+ $(TMPDIR)\winDumpExts.obj,$@,,import32 cw32mti,,
+
+$(TCLLIB): $(TCLDLL)
+ $(implib) -c $@ $(TCLDLL)
+
+$(TCLDLL): cfgdll.cfg $(TCLOBJS) $(TMPDIR)\tcl.def $(TMPDIR)\tcl.res
+ $(link32) $(DLL_LFLAGS) @&&|
+ $(TCLOBJS)
+$@
+-x
+$(DLL_LIBS)
+|, $(TMPDIR)\tcl.def, $(TMPDIR)\tcl.res
+
+
+$(TCLSH): cfgexe.cfg $(TCLSHOBJS) $(TCLLIB) $(TMPDIR)\tclsh.res
+ $(link32) -S:$(STACKSIZE) $(CON_LFLAGS) @&&|
+ $(TCLSHOBJS)
+$@
+-x
+$(CON_LIBS)
+|, &&|
+EXETYPE WINDOWS
+CODE PRELOAD MOVEABLE DISCARDABLE
+DATA PRELOAD MOVEABLE MULTIPLE
+|, $(TMPDIR)\tclsh.res
+
+$(TCLTEST): cfgtest.cfg $(TCLTESTOBJS) $(TCLLIB) $(TMPDIR)\tclsh.res
+ $(link32) -S:$(STACKSIZE) $(CON_LFLAGS) @&&|
+ $(TCLTESTOBJS)
+$@
+-x
+$(CON_LIBS)
+|, &&|
+EXETYPE WINDOWS
+CODE PRELOAD MOVEABLE DISCARDABLE
+DATA PRELOAD MOVEABLE MULTIPLE
+|, $(TMPDIR)\tclsh.res
+
+
+$(TCL16DLL): tcl16.rc $(ROOT)\win\tclWin16.c
+ $(cc16) @&&|
+$(DLL16_CFLAGS) -n$(TMPDIR)
+| $(ROOT)\win\tclWin16.c
+ $(rc16) @&&|
+-i$(INCLUDES) -d__WIN32__;$(DEFINES) -fo$(TMPDIR)\tcl16.res
+| tcl16.rc
+ @copy >nul &&|
+LIBRARY $&;dll
+EXETYPE WINDOWS
+CODE PRELOAD MOVEABLE DISCARDABLE
+DATA PRELOAD MOVEABLE SINGLE
+HEAPSIZE 1024
+EXPORTS
+ WEP @1 RESIDENTNAME
+ UTPROC @2
+| $(TMPDIR)\tclWin16.def
+ $(link16) $(DLL16_LFLAGS) @&&|
+$(TMPDIR)\tclWin16.obj
+$@
+nul
+$(DLL16_LIBS)
+$(TMPDIR)\tclWin16.def
+|
+ $(TOOLS)\bin\rlink $(TMPDIR)\tcl16.res $@
+
+$(TCLPIPEDLL): cfgexe.cfg stub16.c
+ $(cc32) -c -tWC stub16.c
+ $(link32) $(CON_LFLAGS) -L$(TOOLS)\lib \
+ stub16.obj,$@,,import32 cw32,,
+
+$(TCLREGDLL): extdll.cfg $(TMPDIR)\tclWinReg.obj
+ $(link32) $(DLL_LFLAGS) @&&|
+ $(TMPDIR)\tclWinReg.obj
+$@
+-x
+$(DLL_LIBS) $(TCLLIB)
+|,,
+
+#
+# Special test targets
+#
+
+$(CAT32): cat.c
+ $(cc32) -c -Ox -tWC -ocat32.obj cat.c
+ $(link32) $(CON_LFLAGS) -L$(TOOLS)\lib \
+ cat32.obj,$@,,import32 cw32,,
+
+$(CAT16): cat.c
+ $(cc16) -W- -ml -Ox -c -ocat16.obj cat.c
+ $(link16) -Tde -c -L$(TOOLS)\lib $(TOOLS)\lib\c0l.obj cat16.obj,cat16.exe,,cl.lib,,
+
+#######################################################################
+# Implicit Targets
+#######################################################################
+
+
+{$(WINDIR)}.c{$(TMPDIR)}.obj:
+ @$(cc32) $(TCL_CFLAGS) {$< }
+
+{$(GENERICDIR)}.c{$(TMPDIR)}.obj:
+ @$(cc32) $(TCL_CFLAGS) {$< }
+
+{$(ROOT)\compat}.c{$(TMPDIR)}.obj:
+ @$(cc32) $(TCL_CFLAGS) {$< }
+
+{$(WINDIR)}.rc{$(TMPDIR)}.res:
+ $(rc32) -i$(INCLUDES) -fo$@ @&&|
+-d__WIN32__;$(DEFINES) $<
+|
+
+#
+# Special case object file targets
+#
+
+$(TMPDIR)\tclWinReg.obj : extdll.cfg $(ROOT)\win\tclWinReg.c
+ $(cc32) +extdll.cfg -o$@ $(ROOT)\win\tclWinReg.c
+
+$(TMPDIR)\tclAppInit.obj : cfgexe.cfg $(ROOT)\win\tclAppInit.c
+ $(cc32) $(CON_CFLAGS) -o$@ $(ROOT)\win\tclAppInit.c
+
+$(TMPDIR)\testMain.obj : cfgexe.cfg $(ROOT)\win\tclAppInit.c
+ $(cc32) $(TEST_CFLAGS) -o$@ $(ROOT)\win\tclAppInit.c
+
+$(TMPDIR)\tclWin16.obj : $(ROOT)\win\tclWin16.c
+ $(cc16) $(DLL16_CFLAGS) -o$@ $(ROOT)\win\tclWin16.c
+
+#
+# Configuration file targets - these files are implicitly used by the compiler
+#
+
+cfgdll.cfg:
+ @$(CP) &&|
+ -n$(TMPDIR) -I$(INCLUDES) -c -WM
+ -D$(DEFINES) -3 -d -w $(PROJECTCCFLAGS)
+| cfgdll.cfg >NUL
+
+extdll.cfg:
+ @$(CP) &&|
+ -n$(TMPDIR) -I$(INCLUDES) -c -WD
+ -D_RTLDLL;$(DEBUGDEFINES) -3 -d -w $(PROJECTCCFLAGS)
+| extdll.cfg >NUL
+
+cfgexe.cfg:
+ @$(CP) &&|
+ -n$(TMPDIR) -I$(INCLUDES) -c -W
+ -D$(DEFINES) -3 -d -w $(PROJECTCCFLAGS)
+| cfgexe.cfg >NUL
+
+cfgtest.cfg:
+ @$(CP) &&|
+ -n$(TMPDIR) -I$(INCLUDES) -c -W
+ -D$(DEFINES);TCL_TEST -3 -d -w $(PROJECTCCFLAGS)
+| cfgtest.cfg >NUL
+
+cfgcln:
+ -@$(RM) *.cfg
+
+
+# The following rule automatically generates a tcl.def file containing
+# an export entry for every public symbol in the tcl.dll library.
+
+$(TMPDIR)\tcl.def: $(TCLOBJS) $(DUMPEXTS)
+ $(DUMPEXTS) -o $(TMPDIR)\tcl.def $(TCLDLL) @&&|
+ $(TCLOBJS)
+|
+
+
+# the following two rules are a hack to get around the fact that the
+# 16-bit compiler doesn't handle long file names :-(
+
+$(ROOT)\win\tclWinIn.h: $(ROOT)\win\tclWinInt.h
+ $(CP) $(ROOT)\win\tclWinInt.h $(ROOT)\win\tclWinIn.h
+
+$(ROOT)\win\tclWin16.c: $(ROOT)\win\tclWinIn.h
+
+# remove all generated files
+
+clean:
+ -@$(RM) *.exe
+ -@$(RM) *.lib
+ -@$(RM) *.dll
+ -@$(RM) $(TMPDIR)\*.res
+ -@$(RM) $(TMPDIR)\*.def
+ -@$(RM) $(TMPDIR)\*.obj
+ -@$(RM) $(TMPDIR)\*.cfg
+ -@$(RM) $(ROOT)\win\tclWinIn.h
diff --git a/win/makefile.vc b/win/makefile.vc
new file mode 100644
index 0000000..12eda6f
--- /dev/null
+++ b/win/makefile.vc
@@ -0,0 +1,377 @@
+# 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.
+# SCCS: @(#) makefile.vc 1.82 97/11/20 15:14:01
+
+# 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
+#
+# TMPDIR = location where .obj files should be stored during build
+#
+# 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++.
+#
+# TOOLS16 = location of VC++ 1.5 16-bit tools, needed to build thunking
+# library. This information is optional; if the 16-bit compiler
+# is not available, then the 16-bit code will not be built.
+# Tcl will still run without the 16-bit code, but...
+# A. Under Windows 3.X you will any calls to the exec command
+# will return an error.
+# B. A 16-bit program to test the behavior of the exec
+# command under NT and 95 will not be built.
+#
+
+ROOT = ..
+TMPDIR = .
+TOOLS32 = c:\msdev
+TOOLS16 = c:\msvc
+
+# Set this to the appropriate value of /MACHINE: for your platform
+MACHINE = IX86
+
+# Comment the following line to compile with symbols
+NODEBUG=1
+
+# uncomment one of the following lines to compile with TCL_MEM_DEBUG,
+# TCL_MEM_DEBUG, or TCL_COMPILE_DEBUG
+#DEBUGDEFINES = -DTCL_MEM_DEBUG
+#DEBUGDEFINES = -DTCL_MEM_DEBUG -DTCL_COMPILE_DEBUG
+#DEBUGDEFINES = -DTCL_MEM_DEBUG -DTCL_COMPILE_STATS
+#DEBUGDEFINES = -DTCL_MEM_DEBUG -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS
+
+######################################################################
+# Do not modify below this line
+######################################################################
+
+VERSION = 80
+
+TCLLIB = tcl$(VERSION).lib
+TCLDLL = tcl$(VERSION).dll
+TCLPLUGINLIB = tcl$(VERSION)p.lib
+TCLPLUGINDLL = tcl$(VERSION)p.dll
+TCL16DLL = tcl16$(VERSION).dll
+TCLSH = tclsh$(VERSION).exe
+TCLSHP = tclshp$(VERSION).exe
+TCLTEST = tcltest.exe
+DUMPEXTS = $(TMPDIR)\dumpexts.exe
+TCLPIPEDLL = tclpip$(VERSION).dll
+TCLREGDLL = tclreg$(VERSION).dll
+CAT16 = cat16.exe
+CAT32 = cat32.exe
+
+TCLSHOBJS = \
+ $(TMPDIR)\tclAppInit.obj
+
+TCLTESTOBJS = \
+ $(TMPDIR)\tclTest.obj \
+ $(TMPDIR)\tclTestObj.obj \
+ $(TMPDIR)\tclWinTest.obj \
+ $(TMPDIR)\testMain.obj
+
+TCLOBJS = \
+ $(TMPDIR)\panic.obj \
+ $(TMPDIR)\regexp.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)\tclCompExpr.obj \
+ $(TMPDIR)\tclCompile.obj \
+ $(TMPDIR)\tclDate.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)\tclIOSock.obj \
+ $(TMPDIR)\tclIOUtil.obj \
+ $(TMPDIR)\tclLink.obj \
+ $(TMPDIR)\tclListObj.obj \
+ $(TMPDIR)\tclLoad.obj \
+ $(TMPDIR)\tclMain.obj \
+ $(TMPDIR)\tclNamesp.obj \
+ $(TMPDIR)\tclNotify.obj \
+ $(TMPDIR)\tclObj.obj \
+ $(TMPDIR)\tclParse.obj \
+ $(TMPDIR)\tclPipe.obj \
+ $(TMPDIR)\tclPkg.obj \
+ $(TMPDIR)\tclPosixStr.obj \
+ $(TMPDIR)\tclPreserve.obj \
+ $(TMPDIR)\tclProc.obj \
+ $(TMPDIR)\tclStringObj.obj \
+ $(TMPDIR)\tclTimer.obj \
+ $(TMPDIR)\tclUtil.obj \
+ $(TMPDIR)\tclVar.obj \
+ $(TMPDIR)\tclWin32Dll.obj \
+ $(TMPDIR)\tclWinChan.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)\tclWinTime.obj
+
+cc32 = $(TOOLS32)\bin\cl.exe
+link32 = $(TOOLS32)\bin\link.exe
+rc32 = $(TOOLS32)\bin\rc.exe
+include32 = -I$(TOOLS32)\include
+
+cc16 = $(TOOLS16)\bin\cl.exe
+link16 = $(TOOLS16)\bin\link.exe
+rc16 = $(TOOLS16)\bin\rc.exe
+include16 = -I$(TOOLS16)\include
+
+WINDIR = $(ROOT)\win
+GENERICDIR = $(ROOT)\generic
+
+TCL_INCLUDES = -I$(WINDIR) -I$(GENERICDIR)
+TCL_DEFINES = -D__WIN32__ $(DEBUGDEFINES)
+
+TCL_CFLAGS = $(cdebug) $(cflags) $(cvarsdll) $(include32) \
+ $(TCL_INCLUDES) $(TCL_DEFINES)
+CON_CFLAGS = $(cdebug) $(cflags) $(cvars) $(include32) -DCONSOLE
+DOS_CFLAGS = $(cdebug) $(cflags) $(include16) -AL
+DLL16_CFLAGS = $(cdebug) $(cflags) $(include16) -ALw
+
+######################################################################
+# Link flags
+######################################################################
+
+!IFDEF NODEBUG
+ldebug = /RELEASE
+!ELSE
+ldebug = -debug:full -debugtype:cv
+!ENDIF
+
+# declarations common to all linker options
+lcommon = /NODEFAULTLIB /RELEASE /NOLOGO
+
+# declarations for use on Intel i386, i486, and Pentium systems
+!IF "$(MACHINE)" == "IX86"
+DLLENTRY = @12
+lflags = $(lcommon) -align:0x1000 /MACHINE:$(MACHINE)
+!ELSE
+lflags = $(lcommon) /MACHINE:$(MACHINE)
+!ENDIF
+
+conlflags = $(lflags) -subsystem:console -entry:mainCRTStartup
+guilflags = $(lflags) -subsystem:windows -entry:WinMainCRTStartup
+dlllflags = $(lflags) -entry:_DllMainCRTStartup$(DLLENTRY) -dll
+
+!IF "$(MACHINE)" == "PPC"
+libc = libc.lib
+libcdll = crtdll.lib
+!ELSE
+libc = libc.lib oldnames.lib
+libcdll = msvcrt.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)
+
+######################################################################
+# Compile flags
+######################################################################
+
+!IFDEF NODEBUG
+cdebug = -Oti -Gs -GD
+!ELSE
+cdebug = -Z7 -Od -WX
+!ENDIF
+
+# declarations common to all compiler options
+ccommon = -c -W3 -nologo -YX -Dtry=__try -Dexcept=__except
+
+!IF "$(MACHINE)" == "IX86"
+cflags = $(ccommon) -D_X86_=1
+!ELSE
+!IF "$(MACHINE)" == "MIPS"
+cflags = $(ccommon) -D_MIPS_=1
+!ELSE
+!IF "$(MACHINE)" == "PPC"
+cflags = $(ccommon) -D_PPC_=1
+!ELSE
+!IF "$(MACHINE)" == "ALPHA"
+cflags = $(ccommon) -D_ALPHA_=1
+!ENDIF
+!ENDIF
+!ENDIF
+!ENDIF
+
+cvars = -DWIN32 -D_WIN32
+cvarsmt = $(cvars) -D_MT
+cvarsdll = $(cvarsmt) -D_DLL
+
+######################################################################
+# Project specific targets
+######################################################################
+
+release: $(TCLSH) dlls
+dlls: $(TCL16DLL) $(TCLPIPEDLL) $(TCLREGDLL)
+all: $(TCLSH) dlls $(CAT16) $(CAT32)
+tcltest: $(TCLTEST) dlls $(CAT16) $(CAT32)
+plugin: $(TCLPLUGINDLL) $(TCLSHP)
+test: $(TCLTEST) dlls $(CAT16) $(CAT32)
+ $(TCLTEST) <<
+ cd ../tests
+ source all
+<<
+
+$(DUMPEXTS): $(WINDIR)\winDumpExts.c
+ $(cc32) $(CON_CFLAGS) -Fo$(TMPDIR)\ $?
+ set LIB=$(TOOLS32)\lib
+ $(link32) $(ldebug) $(conlflags) $(guilibs) -out:$@ \
+ $(TMPDIR)\winDumpExts.obj
+
+$(TCLLIB): $(TCLDLL)
+
+$(TCLDLL): $(TCLOBJS) $(TMPDIR)\tcl.def $(TMPDIR)\tcl.res
+ set LIB=$(TOOLS32)\lib
+ $(link32) $(ldebug) $(dlllflags) -def:$(TMPDIR)\tcl.def \
+ -out:$@ $(TMPDIR)\tcl.res $(guilibsdll) @<<
+$(TCLOBJS)
+<<
+
+$(TCLPLUGINLIB): $(TCLPLUGINDLL)
+
+$(TCLPLUGINDLL): $(TCLOBJS) $(TMPDIR)\plugin.def $(TMPDIR)\tcl.res
+ set LIB=$(TOOLS32)\lib
+ $(link32) $(ldebug) $(dlllflags) -def:$(TMPDIR)\plugin.def \
+ -out:$@ $(TMPDIR)\tcl.res $(guilibsdll) @<<
+$(TCLOBJS)
+<<
+
+$(TCLSH): $(TCLSHOBJS) $(TCLLIB) $(TMPDIR)\tclsh.res
+ set LIB=$(TOOLS32)\lib
+ $(link32) $(ldebug) $(conlflags) $(TMPDIR)\tclsh.res -stack:2300000 \
+ -out:$@ $(conlibsdll) $(TCLLIB) $(TCLSHOBJS)
+
+$(TCLSHP): $(TCLSHOBJS) $(TCLPLUGINLIB) $(TMPDIR)\tclsh.res
+ set LIB=$(TOOLS32)\lib
+ $(link32) $(ldebug) $(conlflags) $(TMPDIR)\tclsh.res -stack:2300000 \
+ -out:$@ $(conlibsdll) $(TCLPLUGINLIB) $(TCLSHOBJS)
+
+$(TCLTEST): $(TCLTESTOBJS) $(TCLLIB) $(TMPDIR)\tclsh.res
+ set LIB=$(TOOLS32)\lib
+ $(link32) $(ldebug) $(conlflags) $(TMPDIR)\tclsh.res -stack:2300000 \
+ -out:$@ $(conlibsdll) $(TCLLIB) $(TCLTESTOBJS)
+
+$(TCL16DLL): $(WINDIR)\tcl16.rc $(WINDIR)\tclWin16.c
+ if exist $(cc16) $(cc16) @<<
+$(DLL16_CFLAGS) -Fo$(TMPDIR)\ $(WINDIR)\tclWin16.c
+<<
+ @copy << $(TMPDIR)\tclWin16.def > nul
+LIBRARY $(@B);dll
+EXETYPE WINDOWS
+CODE PRELOAD MOVEABLE DISCARDABLE
+DATA PRELOAD MOVEABLE SINGLE
+HEAPSIZE 1024
+EXPORTS
+ WEP @1 RESIDENTNAME
+ UTPROC @2
+<<
+ if exist $(cc16) $(link16) /NOLOGO /ONERROR:NOEXE /NOE @<<
+$(TMPDIR)\tclWin16.obj
+$@
+nul
+$(TOOLS16)\lib\ ldllcew oldnames libw toolhelp
+$(TMPDIR)\tclWin16.def
+<<
+ if exist $(cc16) $(rc16) -i $(GENERICDIR) $(TCL_DEFINES) $(WINDIR)\tcl16.rc $@
+
+$(TCLPIPEDLL): $(WINDIR)\stub16.c
+ $(cc32) $(CON_CFLAGS) -Fo$(TMPDIR)\ $(WINDIR)\stub16.c
+ set LIB=$(TOOLS32)\lib
+ $(link32) $(ldebug) $(conlflags) -out:$@ $(TMPDIR)\stub16.obj $(guilibs)
+
+$(TCLREGDLL): $(TMPDIR)\tclWinReg.obj
+ set LIB=$(TOOLS32)\lib
+ $(link32) $(ldebug) $(dlllflags) -out:$@ $(TMPDIR)\tclWinReg.obj \
+ $(conlibsdll) $(TCLLIB)
+
+$(CAT32): $(WINDIR)\cat.c
+ $(cc32) $(CON_CFLAGS) -Fo$(TMPDIR)\ $?
+ set LIB=$(TOOLS32)\lib
+ $(link32) $(conlflags) -out:$@ -stack:16384 $(TMPDIR)\cat.obj $(conlibs)
+
+$(CAT16): $(WINDIR)\cat.c
+ if exist $(cc16) $(cc16) $(DOS_CFLAGS) -Fo$(TMPDIR)\ $?
+ set LIB=$(TOOLS16)\lib
+ if exist $(cc16) $(link16) /NOLOGO /ONERROR:NOEXE /NOI /STACK:16384 \
+ $(TMPDIR)\cat.obj,$@,nul,llibce.lib,nul
+
+$(TMPDIR)\tcl.def: $(DUMPEXTS) $(TCLOBJS)
+ $(DUMPEXTS) -o $@ $(TCLDLL) @<<
+$(TCLOBJS)
+<<
+
+$(TMPDIR)\plugin.def: $(DUMPEXTS) $(TCLOBJS)
+ $(DUMPEXTS) -o $@ $(TCLPLUGINDLL) @<<
+$(TCLOBJS)
+<<
+
+#
+# Special case object file targets
+#
+
+$(TMPDIR)\testMain.obj: $(WINDIR)\tclAppInit.c
+ $(cc32) $(TCL_CFLAGS) -DTCL_TEST -Fo$(TMPDIR)\testMain.obj $?
+
+#
+# Implicit rules
+#
+
+{$(WINDIR)}.c{$(TMPDIR)}.obj:
+ $(cc32) $(TCL_CFLAGS) -Fo$(TMPDIR)\ $<
+
+{$(GENERICDIR)}.c{$(TMPDIR)}.obj:
+ $(cc32) $(TCL_CFLAGS) -Fo$(TMPDIR)\ $<
+
+{$(ROOT)\compat}.c{$(TMPDIR)}.obj:
+ $(cc32) $(TCL_CFLAGS) -Fo$(TMPDIR)\ $<
+
+{$(WINDIR)}.rc{$(TMPDIR)}.res:
+ $(rc32) -fo $@ -r -i $(GENERICDIR) -i $(WINDIR) -D__WIN32__ \
+ $(TCL_DEFINES) $<
+
+clean:
+ -@del *.exp
+ -@del *.lib
+ -@del *.dll
+ -@del *.exe
+ -@del $(TMPDIR)\*.obj
+ -@del $(TMPDIR)\*.res
+ -@del $(TMPDIR)\*.def
diff --git a/win/pkgIndex.tcl b/win/pkgIndex.tcl
new file mode 100644
index 0000000..6847aa8
--- /dev/null
+++ b/win/pkgIndex.tcl
@@ -0,0 +1,11 @@
+# Tcl package index file, version 1.0
+# This file contains package information for Windows-specific extensions.
+#
+# 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.
+#
+# SCCS: @(#) pkgIndex.tcl 1.1 97/06/23 14:25:47
+
+package ifneeded registry 1.0 [list tclPkgSetup $dir registry 1.0 {{tclreg80.dll load registry}}]
diff --git a/win/stub16.c b/win/stub16.c
new file mode 100644
index 0000000..5fafd29
--- /dev/null
+++ b/win/stub16.c
@@ -0,0 +1,198 @@
+/*
+ * 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.
+ *
+ * SCCS: @(#) stub16.c 1.5 96/12/11 20:01:58
+ */
+
+#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);
+ CloseHandle(pi.hProcess);
+ CloseHandle(pi.hThread);
+ result = 0;
+
+ 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.rc b/win/tcl.rc
new file mode 100644
index 0000000..e7eabd1
--- /dev/null
+++ b/win/tcl.rc
@@ -0,0 +1,42 @@
+// SCCS: @(#) tcl.rc 1.24 97/04/01 19:19:43
+//
+// Version
+//
+
+#define RESOURCE_INCLUDED
+#include <tcl.h>
+
+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 0x4L
+ FILETYPE 0x2L
+ FILESUBTYPE 0x0L
+BEGIN
+ BLOCK "StringFileInfo"
+ BEGIN
+ BLOCK "040904b0"
+ BEGIN
+ VALUE "FileDescription", "Tcl DLL\0"
+ VALUE "OriginalFilename", "tcl" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) ".dll\0"
+ VALUE "CompanyName", "Sun Microsystems, Inc\0"
+ VALUE "FileVersion", TCL_PATCH_LEVEL
+ VALUE "LegalCopyright", "Copyright \251 1995-1997\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/tcl16.rc b/win/tcl16.rc
new file mode 100644
index 0000000..5e4498e
--- /dev/null
+++ b/win/tcl16.rc
@@ -0,0 +1,37 @@
+// SCCS: @(#) tcl16.rc 1.17 96/09/18 18:19:00
+//
+// Version
+//
+
+#define RESOURCE_INCLUDED
+#include <tcl.h>
+
+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 0x1L
+ FILETYPE 0x2L
+ FILESUBTYPE 0x0L
+BEGIN
+ BLOCK "StringFileInfo"
+ BEGIN
+ BLOCK "040904b0"
+ BEGIN
+ VALUE "FileDescription", "Tcl16 DLL, 16-bit thunking module\0"
+ VALUE "OriginalFilename", "tcl16" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) ".dll\0"
+ VALUE "CompanyName", "Sun Microsystems, Inc\0"
+ VALUE "FileVersion", TCL_PATCH_LEVEL
+ VALUE "LegalCopyright", "Copyright \251 1995-1996\0"
+ VALUE "ProductName", "Tcl " TCL_VERSION " for Windows\0"
+ VALUE "ProductVersion", TCL_PATCH_LEVEL
+ END
+ END
+ BLOCK "VarFileInfo"
+ BEGIN
+ VALUE "Translation", 0x409, 1200
+ END
+END
+
+
diff --git a/win/tclAppInit.c b/win/tclAppInit.c
new file mode 100644
index 0000000..10a77cb
--- /dev/null
+++ b/win/tclAppInit.c
@@ -0,0 +1,259 @@
+/*
+ * 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 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.
+ *
+ * SCCS: @(#) tclAppInit.c 1.12 97/04/30 11:04:50
+ */
+
+#include "tcl.h"
+#include <windows.h>
+#include <locale.h>
+
+#ifdef TCL_TEST
+EXTERN int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp));
+EXTERN int TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp));
+#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. */
+{
+ char *p;
+ char buffer[MAX_PATH];
+
+ /*
+ * 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 = '/';
+ }
+ }
+
+ Tcl_Main(argc, argv, Tcl_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 interp->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;
+ }
+#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();
+
+ /*
+ * 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 (isspace(*p)) {
+ size++;
+ while (isspace(*p)) {
+ p++;
+ }
+ if (*p == '\0') {
+ break;
+ }
+ }
+ }
+ argSpace = (char *) ckalloc((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 (isspace(*p)) {
+ 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 && isspace(*p))) {
+ break;
+ }
+ if (copy != 0) {
+ *arg = *p;
+ arg++;
+ }
+ p++;
+ }
+ *arg = '\0';
+ argSpace = arg + 1;
+ }
+ argv[argc] = NULL;
+
+ *argcPtr = argc;
+ *argvPtr = argv;
+}
diff --git a/win/tclWin16.c b/win/tclWin16.c
new file mode 100644
index 0000000..d8ea801
--- /dev/null
+++ b/win/tclWin16.c
@@ -0,0 +1,347 @@
+/*
+ * tclWin16.c --
+ *
+ * This file contains code for a 16-bit DLL to handle 32-to-16 bit
+ * thunking. This is necessary for the Win32s SynchSpawn() call.
+ *
+ * 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.
+ *
+ * SCCS: @(#) tclWin16.c 1.18 97/05/23 13:13:32
+ */
+
+#define STRICT
+
+#include <windows.h>
+#include <toolhelp.h>
+
+#include <stdio.h>
+#include <string.h>
+
+static int WinSpawn(char *command);
+static int DosSpawn(char *command, char *fromFileName,
+ char *toFileName);
+static int WaitForExit(int inst);
+
+/*
+ * The following data is used to construct a .pif file that wraps the
+ * .bat file that runs the 16-bit application (that Jack built).
+ * The .pif file causes the .bat file to run in an iconified window.
+ * Otherwise, when we try to exec something, a DOS box pops up,
+ * obscuring everything, and then almost immediately flickers out of
+ * existence, which is rather disconcerting.
+ */
+
+static char pifData[545] = {
+'\000', '\013', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\200', '\000', '\200', '\000', '\103', '\117', '\115', '\115',
+'\101', '\116', '\104', '\056', '\103', '\117', '\115', '\000',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\020', '\000', '\000', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\177', '\001', '\000',
+'\377', '\031', '\120', '\000', '\000', '\007', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\340',
+'\040', '\115', '\111', '\103', '\122', '\117', '\123', '\117',
+'\106', '\124', '\040', '\120', '\111', '\106', '\105', '\130',
+'\000', '\207', '\001', '\000', '\000', '\161', '\001', '\127',
+'\111', '\116', '\104', '\117', '\127', '\123', '\040', '\063',
+'\070', '\066', '\040', '\063', '\056', '\060', '\000', '\005',
+'\002', '\235', '\001', '\150', '\000', '\200', '\002', '\200',
+'\000', '\144', '\000', '\062', '\000', '\000', '\004', '\000',
+'\000', '\000', '\004', '\000', '\000', '\002', '\020', '\002',
+'\000', '\037', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000', '\000', '\000', '\000', '\000', '\057', '\143', '\040',
+'\146', '\157', '\157', '\056', '\142', '\141', '\164', '\000',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\040', '\040', '\040',
+'\040', '\040', '\040', '\040', '\040', '\127', '\111', '\116',
+'\104', '\117', '\127', '\123', '\040', '\062', '\070', '\066',
+'\040', '\063', '\056', '\060', '\000', '\377', '\377', '\033',
+'\002', '\006', '\000', '\000', '\000', '\000', '\000', '\000',
+'\000'
+};
+
+static HINSTANCE hInstance;
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * LibMain --
+ *
+ * 16-bit DLL entry point.
+ *
+ * Results:
+ * Returns 1.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int CALLBACK
+LibMain(
+ HINSTANCE hinst,
+ WORD wDS,
+ WORD cbHeap,
+ LPSTR unused)
+{
+ hInstance = hinst;
+ wDS = wDS; /* lint. */
+ cbHeap = cbHeap; /* lint. */
+ unused = unused; /* lint. */
+
+ return TRUE;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * UTProc --
+ *
+ * Universal Thunk dispatch routine. Executes a 16-bit DOS
+ * application or a 16-bit or 32-bit Windows application and
+ * waits for it to complete.
+ *
+ * Results:
+ * 1 if the application could be run, 0 or -1 on failure.
+ *
+ * Side effects:
+ * Executes 16-bit code.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int WINAPI
+UTProc(buf, func)
+ void *buf;
+ DWORD func;
+{
+ char **args;
+
+ args = (char **) buf;
+ if (func == 0) {
+ return DosSpawn(args[0], args[1], args[2]);
+ } else {
+ return WinSpawn(args[0]);
+ }
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * WinSpawn --
+ *
+ * Start a 16-bit or 32-bit Windows application with optional
+ * command line arguments and wait for it to finish. Windows
+ * applications do not handle input/output redirection.
+ *
+ * Results:
+ * The return value is 1 if the application could be run, 0 otherwise.
+ *
+ * Side effects:
+ * Whatever the application does.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+static int
+WinSpawn(command)
+ char *command; /* The command line, consisting of the name
+ * of the executable to run followed by any
+ * number of arguments to the executable. */
+{
+ return WaitForExit(WinExec(command, SW_SHOW));
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * DosSpawn --
+ *
+ * Start a 16-bit DOS program with optional command line arguments
+ * and wait for it to finish. Input and output can be redirected
+ * from the specified files, but there is no such thing as stderr
+ * under Win32s.
+ *
+ * This procedure to constructs a temporary .pif file that wraps a
+ * temporary .bat file that runs the 16-bit application. The .bat
+ * file is necessary to get the redirection symbols '<' and '>' to
+ * work, because WinExec() doesn't accept them. The .pif file is
+ * necessary to cause the .bat file to run in an iconified window,
+ * to avoid having a large DOS box pop up, obscuring everything, and
+ * then almost immediately flicker out of existence, which is rather
+ * disconcerting.
+ *
+ * Results:
+ * The return value is 1 if the application could be run, 0 otherwise.
+ *
+ * Side effects:
+ * Whatever the application does.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static int
+DosSpawn(command, fromFileName, toFileName)
+ char *command; /* The name of the program, plus any
+ * arguments, to be run. */
+ char *fromFileName; /* Standard input for the program is to be
+ * redirected from this file, or NULL for no
+ * standard input. */
+ char *toFileName; /* Standard output for the program is to be
+ * redirected to this file, or NULL to
+ * discard standard output. */
+{
+ int result;
+ HFILE batFile, pifFile;
+ char batFileName[144], pifFileName[144];
+
+ GetTempFileName(0, "tcl", 0, batFileName);
+ unlink(batFileName);
+ strcpy(strrchr(batFileName, '.'), ".bat");
+ batFile = _lcreat(batFileName, 0);
+
+ GetTempFileName(0, "tcl", 0, pifFileName);
+ unlink(pifFileName);
+ strcpy(strrchr(pifFileName, '.'), ".pif");
+ pifFile = _lcreat(pifFileName, 0);
+
+ _lwrite(batFile, command, strlen(command));
+ if (fromFileName == NULL) {
+ _lwrite(batFile, " < nul", 6);
+ } else {
+ _lwrite(batFile, " < ", 3);
+ _lwrite(batFile, fromFileName, strlen(fromFileName));
+ }
+ if (toFileName == NULL) {
+ _lwrite(batFile, " > nul", 6);
+ } else {
+ _lwrite(batFile, " > ", 3);
+ _lwrite(batFile, toFileName, strlen(toFileName));
+ }
+ _lwrite(batFile, "\r\n\032", 3);
+ _lclose(batFile);
+
+ strcpy(pifData + 0x1c8, batFileName);
+ _lwrite(pifFile, pifData, sizeof(pifData));
+ _lclose(pifFile);
+
+ result = WaitForExit(WinExec(pifFileName, SW_MINIMIZE));
+
+ unlink(pifFileName);
+ unlink(batFileName);
+
+ return result;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * WaitForExit --
+ *
+ * Wait until the application with the given instance handle has
+ * finished. PeekMessage() is used to yield the processor;
+ * otherwise, nothing else could execute on the system.
+ *
+ * Results:
+ * The return value is 1 if the process exited successfully,
+ * or 0 otherwise.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static int
+WaitForExit(inst)
+ int inst; /* Identifies the instance handle of the
+ * process to wait for. */
+{
+ TASKENTRY te;
+ MSG msg;
+ UINT timer;
+
+ if (inst < 32) {
+ return 0;
+ }
+
+ te.dwSize = sizeof(te);
+ te.hInst = 0;
+ TaskFirst(&te);
+ do {
+ if (te.hInst == (HINSTANCE) inst) {
+ break;
+ }
+ } while (TaskNext(&te) != FALSE);
+
+ if (te.hInst != (HINSTANCE) inst) {
+ return 0;
+ }
+
+ timer = SetTimer(NULL, 0, 0, NULL);
+ while (1) {
+ if (GetMessage(&msg, NULL, 0, 0) != 0) {
+ TranslateMessage(&msg);
+ DispatchMessage(&msg);
+ }
+ TaskFirst(&te);
+ do {
+ if (te.hInst == (HINSTANCE) inst) {
+ break;
+ }
+ } while (TaskNext(&te) != FALSE);
+
+ if (te.hInst != (HINSTANCE) inst) {
+ KillTimer(NULL, timer);
+ return 1;
+ }
+ }
+}
diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c
new file mode 100644
index 0000000..3abc97e
--- /dev/null
+++ b/win/tclWin32Dll.c
@@ -0,0 +1,362 @@
+/*
+ * tclWin32Dll.c --
+ *
+ * This file contains the DLL entry point which sets up the 32-to-16-bit
+ * thunking code for SynchSpawn if the library is running under Win32s.
+ *
+ * Copyright (c) 1995-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.
+ *
+ * SCCS: @(#) tclWin32Dll.c 1.21 97/08/05 11:47:10
+ */
+
+#include "tclWinInt.h"
+
+typedef DWORD (WINAPI * UT32PROC)(LPVOID lpBuff, DWORD dwUserDefined,
+ LPVOID *lpTranslationList);
+
+typedef BOOL (WINAPI * PUTREGISTER)(HANDLE hModule, LPCSTR SixteenBitDLL,
+ LPCSTR InitName, LPCSTR ProcName, UT32PROC* ThirtyTwoBitThunk,
+ FARPROC UT32Callback, LPVOID Buff);
+
+typedef VOID (WINAPI * PUTUNREGISTER)(HANDLE hModule);
+
+static PUTUNREGISTER UTUnRegister = NULL;
+static int tclProcessesAttached = 0;
+
+/*
+ * The following data structure is used to keep track of all of the DLL's
+ * opened by Tcl so that they can be freed with the Tcl.dll is unloaded.
+ */
+
+typedef struct LibraryList {
+ HINSTANCE handle;
+ struct LibraryList *nextPtr;
+} LibraryList;
+
+static LibraryList *libraryList = NULL; /* List of currently loaded DLL's. */
+
+static HINSTANCE tclInstance; /* Global library instance handle. */
+static int tclPlatformId; /* Running under NT, 95, or Win32s? */
+
+/*
+ * Declarations for functions that are only used in this file.
+ */
+
+static void UnloadLibraries _ANSI_ARGS_((void));
+
+/*
+ * The following declaration is for the VC++ DLL entry point.
+ */
+
+BOOL APIENTRY DllMain _ANSI_ARGS_((HINSTANCE hInst,
+ DWORD reason, LPVOID reserved));
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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. */
+{
+ OSVERSIONINFO os;
+
+ switch (reason) {
+ case DLL_PROCESS_ATTACH:
+
+ /*
+ * Registration of UT need to be done only once for first
+ * attaching process. At that time set the tclWin32s flag
+ * to indicate if the DLL is executing under Win32s or not.
+ */
+
+ if (tclProcessesAttached++) {
+ return FALSE; /* Not the first initialization. */
+ }
+
+ tclInstance = hInst;
+ os.dwOSVersionInfoSize = sizeof(os);
+ GetVersionEx(&os);
+ tclPlatformId = os.dwPlatformId;
+
+ /*
+ * The following code stops Windows 3.x 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, the system doesn't automatically put up dialogs
+ * when the above operations fail.
+ */
+
+ if (tclPlatformId == VER_PLATFORM_WIN32s) {
+ SetErrorMode(SetErrorMode(0) | SEM_FAILCRITICALERRORS);
+ }
+
+ return TRUE;
+
+ case DLL_PROCESS_DETACH:
+
+ tclProcessesAttached--;
+ if (tclProcessesAttached == 0) {
+
+ /*
+ * Unregister the Tcl thunk.
+ */
+
+ if (UTUnRegister != NULL) {
+ UTUnRegister(hInst);
+ }
+
+ /*
+ * Cleanup any dynamically loaded libraries.
+ */
+
+ UnloadLibraries();
+
+ /*
+ * And finally finalize our use of Tcl.
+ */
+
+ Tcl_Finalize();
+ }
+ break;
+ }
+
+ return TRUE;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclWinLoadLibrary --
+ *
+ * This function is a wrapper for the system LoadLibrary. It is
+ * responsible for adding library handles to the library list so
+ * the libraries can be freed when tcl.dll is unloaded.
+ *
+ * Results:
+ * Returns the handle of the newly loaded library, or NULL on
+ * failure.
+ *
+ * Side effects:
+ * Loads the specified library into the process.
+ *
+ *----------------------------------------------------------------------
+ */
+
+HINSTANCE
+TclWinLoadLibrary(name)
+ char *name; /* Library file to load. */
+{
+ HINSTANCE handle;
+ LibraryList *ptr;
+
+ handle = LoadLibrary(name);
+ if (handle != NULL) {
+ ptr = (LibraryList*) ckalloc(sizeof(LibraryList));
+ ptr->handle = handle;
+ ptr->nextPtr = libraryList;
+ libraryList = ptr;
+ } else {
+ TclWinConvertError(GetLastError());
+ }
+ return handle;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * UnloadLibraries --
+ *
+ * Frees any dynamically allocated libraries loaded by Tcl.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Frees the libraries on the library list as well as the list.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+UnloadLibraries()
+{
+ LibraryList *ptr;
+
+ while (libraryList != NULL) {
+ FreeLibrary(libraryList->handle);
+ ptr = libraryList->nextPtr;
+ ckfree((char*)libraryList);
+ libraryList = ptr;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclWinSynchSpawn --
+ *
+ * 32-bit entry point to the 16-bit SynchSpawn code.
+ *
+ * Results:
+ * 1 on success, 0 on failure.
+ *
+ * Side effects:
+ * Spawns a command and waits for it to complete.
+ *
+ *----------------------------------------------------------------------
+ */
+int
+TclWinSynchSpawn(void *args, int type, void **trans, Tcl_Pid *pidPtr)
+{
+ static UT32PROC UTProc = NULL;
+ static int utErrorCode;
+
+ if (UTUnRegister == NULL) {
+ /*
+ * Load the Universal Thunking routines from kernel32.dll.
+ */
+
+ HINSTANCE hKernel;
+ PUTREGISTER UTRegister;
+ char buffer[] = "TCL16xx.DLL";
+
+ hKernel = TclWinLoadLibrary("Kernel32.Dll");
+ if (hKernel == NULL) {
+ return 0;
+ }
+
+ UTRegister = (PUTREGISTER) GetProcAddress(hKernel, "UTRegister");
+ UTUnRegister = (PUTUNREGISTER) GetProcAddress(hKernel, "UTUnRegister");
+ if (!UTRegister || !UTUnRegister) {
+ UnloadLibraries();
+ return 0;
+ }
+
+ /*
+ * Construct the complete name of tcl16xx.dll.
+ */
+
+ buffer[5] = '0' + TCL_MAJOR_VERSION;
+ buffer[6] = '0' + TCL_MINOR_VERSION;
+
+ /*
+ * Register the Tcl thunk.
+ */
+
+ if (UTRegister(tclInstance, buffer, NULL, "UTProc", &UTProc, NULL,
+ NULL) == FALSE) {
+ utErrorCode = GetLastError();
+ }
+ }
+
+ if (UTProc == NULL) {
+ /*
+ * The 16-bit thunking DLL wasn't found. Return error code that
+ * indicates this problem.
+ */
+
+ SetLastError(utErrorCode);
+ return 0;
+ }
+
+ UTProc(args, type, trans);
+ *pidPtr = 0;
+ return 1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclWinGetTclInstance --
+ *
+ * Retrieves the global library instance handle.
+ *
+ * Results:
+ * Returns the global library instance handle.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+HINSTANCE
+TclWinGetTclInstance()
+{
+ return tclInstance;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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.
+ * VER_PLATFORM_WIN32_WINDOWS Win32 on Windows 95.
+ * VER_PLATFORM_WIN32_NT Win32 on Windows NT
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclWinGetPlatformId()
+{
+ return tclPlatformId;
+}
diff --git a/win/tclWinChan.c b/win/tclWinChan.c
new file mode 100644
index 0000000..248e14b
--- /dev/null
+++ b/win/tclWinChan.c
@@ -0,0 +1,1185 @@
+/*
+ * 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.
+ *
+ * SCCS: @(#) tclWinChan.c 1.75 97/09/26 16:17:46
+ */
+
+#include "tclWinInt.h"
+
+/*
+ * This is the size of the channel name for File based channels
+ */
+
+#define CHANNEL_NAME_SIZE 64
+static char channelName[CHANNEL_NAME_SIZE+1];
+
+/*
+ * The following variable is used to tell whether this module has been
+ * initialized.
+ */
+
+static int initialized = 0;
+
+/*
+ * 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. */
+
+/*
+ * 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;
+
+/*
+ * List of all file channels currently open.
+ */
+
+static FileInfo *firstFilePtr;
+
+/*
+ * 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 ComGetOptionProc _ANSI_ARGS_((ClientData instanceData,
+ Tcl_Interp *interp, char *optionName,
+ Tcl_DString *dsPtr));
+static int ComInputProc _ANSI_ARGS_((ClientData instanceData,
+ char *buf, int toRead, int *errorCode));
+static int ComSetOptionProc _ANSI_ARGS_((ClientData instanceData,
+ Tcl_Interp *interp, char *optionName,
+ char *value));
+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 void 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. */
+ FileBlockProc, /* Set blocking or non-blocking mode.*/
+ 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. */
+};
+
+static Tcl_ChannelType comChannelType = {
+ "com", /* Type name. */
+ FileBlockProc, /* Set blocking or non-blocking mode.*/
+ FileCloseProc, /* Close proc. */
+ ComInputProc, /* Input proc. */
+ FileOutputProc, /* Output proc. */
+ NULL, /* Seek proc. */
+ ComSetOptionProc, /* Set option proc. */
+ ComGetOptionProc, /* Get option proc. */
+ FileWatchProc, /* Set up notifier to watch the channel. */
+ FileGetHandleProc /* Get an OS handle from channel. */
+};
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 void
+FileInit()
+{
+ initialized = 1;
+ firstFilePtr = NULL;
+ Tcl_CreateEventSource(FileSetupProc, FileCheckProc, NULL);
+ Tcl_CreateExitHandler(FileChannelExitHandler, NULL);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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);
+ initialized = 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 };
+
+ if (!(flags & TCL_FILE_EVENTS)) {
+ return;
+ }
+
+ /*
+ * Check to see if there is a ready file. If so, poll.
+ */
+
+ for (infoPtr = 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;
+
+ 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 = 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;
+
+ 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 = 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;
+
+ /*
+ * Remove the file from the watch list.
+ */
+
+ FileWatchProc(instanceData, 0);
+
+ if (CloseHandle(fileInfoPtr->handle) == FALSE) {
+ TclWinConvertError(GetLastError());
+ errorCode = errno;
+ }
+ for (nextPtrPtr = &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());
+ 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_GetChannelFile 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;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ComInputProc --
+ *
+ * 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
+ComInputProc(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;
+ DWORD dw;
+ COMSTAT cs;
+
+ *errorCode = 0;
+ infoPtr = (FileInfo *) instanceData;
+
+ if (ClearCommError(infoPtr->handle, &dw, &cs)) {
+ if (dw != 0) {
+ *errorCode = EIO;
+ return -1;
+ }
+ if (cs.cbInQue != 0) {
+ if ((DWORD) bufSize > cs.cbInQue) {
+ bufSize = cs.cbInQue;
+ }
+ } else {
+ if (infoPtr->flags & FILE_ASYNC) {
+ errno = *errorCode = EAGAIN;
+ return -1;
+ } else {
+ bufSize = 1;
+ }
+ }
+ }
+
+ if (ReadFile(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize, &bytesRead,
+ (LPOVERLAPPED) NULL) == FALSE) {
+ TclWinConvertError(GetLastError());
+ *errorCode = errno;
+ return -1;
+ }
+
+ return bytesRead;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ComSetOptionProc --
+ *
+ * Sets an option on a channel.
+ *
+ * Results:
+ * A standard Tcl result. Also sets interp->result on error if
+ * interp is not NULL.
+ *
+ * Side effects:
+ * May modify an option on a device.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ComSetOptionProc(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. */
+{
+ FileInfo *infoPtr;
+ DCB dcb;
+ int len;
+
+ infoPtr = (FileInfo *) instanceData;
+
+ len = strlen(optionName);
+ if ((len > 1) && (strncmp(optionName, "-mode", len) == 0)) {
+ if (GetCommState(infoPtr->handle, &dcb)) {
+ if ((BuildCommDCB(value, &dcb) == 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 {
+ return Tcl_BadChannelOption(interp, optionName, "mode");
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ComGetOptionProc --
+ *
+ * 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
+ComGetOptionProc(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). */
+{
+ FileInfo *infoPtr;
+ DCB dcb;
+ int len;
+
+ infoPtr = (FileInfo *) instanceData;
+
+ if (optionName == NULL) {
+ Tcl_DStringAppendElement(dsPtr, "-mode");
+ len = 0;
+ } else {
+ len = strlen(optionName);
+ }
+ if ((len == 0) ||
+ ((len > 1) && (strncmp(optionName, "-mode", len) == 0))) {
+ if (GetCommState(infoPtr->handle, &dcb) == 0) {
+ /*
+ * shouldn't we flag an error instead ?
+ */
+ Tcl_DStringAppendElement(dsPtr, "");
+ } else {
+ char parity;
+ char *stop;
+ char buf[32];
+
+ parity = 'n';
+ if (dcb.Parity < 4) {
+ parity = "noems"[dcb.Parity];
+ }
+
+ stop = (dcb.StopBits == ONESTOPBIT) ? "1" :
+ (dcb.StopBits == ONE5STOPBITS) ? "1.5" : "2";
+
+ wsprintf(buf, "%d,%c,%d,%s", dcb.BaudRate, parity, dcb.ByteSize,
+ stop);
+ Tcl_DStringAppendElement(dsPtr, buf);
+ }
+ return TCL_OK;
+ } else {
+ return Tcl_BadChannelOption(interp, optionName, "mode");
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_OpenFileChannel --
+ *
+ * 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
+Tcl_OpenFileChannel(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? */
+{
+ FileInfo *infoPtr;
+ int seekFlag, mode, channelPermissions;
+ DWORD accessMode, createMode, shareMode, flags;
+ char *nativeName;
+ Tcl_DString buffer;
+ DCB dcb;
+ Tcl_ChannelType *channelTypePtr;
+ HANDLE handle;
+
+ if (!initialized) {
+ FileInit();
+ }
+
+ mode = TclGetOpenMode(interp, modeString, &seekFlag);
+ if (mode == -1) {
+ return NULL;
+ }
+
+ nativeName = Tcl_TranslateFileName(interp, fileName, &buffer);
+ if (nativeName == NULL) {
+ return NULL;
+ }
+
+ switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
+ case O_RDONLY:
+ accessMode = GENERIC_READ;
+ channelPermissions = TCL_READABLE;
+ break;
+ case O_WRONLY:
+ accessMode = GENERIC_WRITE;
+ channelPermissions = TCL_WRITABLE;
+ break;
+ case O_RDWR:
+ accessMode = (GENERIC_READ | GENERIC_WRITE);
+ channelPermissions = (TCL_READABLE | TCL_WRITABLE);
+ break;
+ default:
+ panic("Tcl_OpenFileChannel: 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 = GetFileAttributes(nativeName);
+ if (flags == 0xFFFFFFFF) {
+ flags = 0;
+ }
+ }
+
+ /*
+ * Set up the file sharing mode. We want to allow simultaneous access.
+ */
+
+ shareMode = FILE_SHARE_READ | FILE_SHARE_WRITE;
+
+ /*
+ * Now we get to create the file.
+ */
+
+ handle = CreateFile(nativeName, accessMode, shareMode, NULL, createMode,
+ flags, (HANDLE) NULL);
+
+ if (handle == INVALID_HANDLE_VALUE) {
+ DWORD err;
+
+ openerr:
+ 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;
+ }
+
+ if (GetFileType(handle) == FILE_TYPE_CHAR) {
+ dcb.DCBlength = sizeof( DCB ) ;
+ if (GetCommState(handle, &dcb)) {
+ /*
+ * This is a com port. Reopen it with the correct modes.
+ */
+
+ COMMTIMEOUTS cto;
+
+ CloseHandle(handle);
+ handle = CreateFile(nativeName, accessMode, 0, NULL, OPEN_EXISTING,
+ flags, NULL);
+ if (handle == INVALID_HANDLE_VALUE) {
+ goto openerr;
+ }
+
+ /*
+ * FileInit the com port.
+ */
+
+ SetCommMask(handle, EV_RXCHAR);
+ SetupComm(handle, 4096, 4096);
+ PurgeComm(handle, PURGE_TXABORT | PURGE_RXABORT | PURGE_TXCLEAR
+ | PURGE_RXCLEAR);
+ cto.ReadIntervalTimeout = MAXDWORD;
+ cto.ReadTotalTimeoutMultiplier = 0;
+ cto.ReadTotalTimeoutConstant = 0;
+ cto.WriteTotalTimeoutMultiplier = 0;
+ cto.WriteTotalTimeoutConstant = 0;
+ SetCommTimeouts(handle, &cto);
+
+ GetCommState(handle, &dcb);
+ SetCommState(handle, &dcb);
+ channelTypePtr = &comChannelType;
+ } else {
+ channelTypePtr = &fileChannelType;
+ }
+ } else {
+ channelTypePtr = &fileChannelType;
+ }
+ Tcl_DStringFree(&buffer);
+
+ infoPtr = (FileInfo *) ckalloc((unsigned) sizeof(FileInfo));
+ infoPtr->nextPtr = firstFilePtr;
+ firstFilePtr = infoPtr;
+ infoPtr->validMask = channelPermissions;
+ infoPtr->watchMask = 0;
+ infoPtr->flags = (mode & O_APPEND) ? FILE_APPEND : 0;
+ infoPtr->handle = handle;
+
+ sprintf(channelName, "file%d", (int) handle);
+
+ infoPtr->channel = Tcl_CreateChannel(channelTypePtr, channelName,
+ (ClientData) infoPtr, channelPermissions);
+
+ if (seekFlag) {
+ if (Tcl_Seek(infoPtr->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, infoPtr->channel);
+ return NULL;
+ }
+ }
+
+ /*
+ * Files have default translation of AUTO and ^Z eof char, which
+ * means that a ^Z will be appended to them at close.
+ */
+
+ Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
+ Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}");
+ return infoPtr->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(handle, mode)
+ ClientData handle; /* OS level handle */
+ int mode; /* ORed combination of TCL_READABLE and
+ * TCL_WRITABLE to indicate file mode. */
+{
+ char channelName[20];
+ FileInfo *infoPtr;
+
+ if (!initialized) {
+ FileInit();
+ }
+
+ if (mode == 0) {
+ return NULL;
+ }
+
+ sprintf(channelName, "file%d", (int) handle);
+
+ /*
+ * See if a channel with this handle already exists.
+ */
+
+ for (infoPtr = firstFilePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
+ if (infoPtr->handle == (HANDLE) handle) {
+ return (mode == infoPtr->validMask) ? infoPtr->channel : NULL;
+ }
+ }
+
+ infoPtr = (FileInfo *) ckalloc((unsigned) sizeof(FileInfo));
+ infoPtr->nextPtr = firstFilePtr;
+ firstFilePtr = infoPtr;
+ infoPtr->validMask = mode;
+ infoPtr->watchMask = 0;
+ infoPtr->flags = 0;
+ infoPtr->handle = (HANDLE) handle;
+ infoPtr->channel = Tcl_CreateChannel(&fileChannelType, channelName,
+ (ClientData) infoPtr, mode);
+
+ /*
+ * Windows files have AUTO translation mode and ^Z eof char on input.
+ */
+
+ Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
+ Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}");
+ return infoPtr->channel;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGetDefaultStdChannel --
+ *
+ * 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
+TclGetDefaultStdChannel(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 will 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);
+
+ /*
+ * 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;
+}
diff --git a/win/tclWinError.c b/win/tclWinError.c
new file mode 100644
index 0000000..5361174
--- /dev/null
+++ b/win/tclWinError.c
@@ -0,0 +1,393 @@
+/*
+ * 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.
+ *
+ * SCCS: @(#) tclWinError.c 1.7 97/10/28 17:30:33
+ */
+
+#include "tclInt.h"
+#include "tclPort.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
new file mode 100644
index 0000000..f2df779
--- /dev/null
+++ b/win/tclWinFCmd.c
@@ -0,0 +1,1401 @@
+/*
+ * tclWinFCmd.c
+ *
+ * This file implements the Windows specific portion of file manipulation
+ * subcommands of the "file" command.
+ *
+ * Copyright (c) 1996-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.
+ *
+ * SCCS: @(#) tclWinFCmd.c 1.20 97/10/10 11:50:14
+ */
+
+#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, char *fileName,
+ Tcl_Obj **attributePtrPtr));
+static int GetWinFileLongName _ANSI_ARGS_((Tcl_Interp *interp,
+ int objIndex, char *fileName,
+ Tcl_Obj **attributePtrPtr));
+static int GetWinFileShortName _ANSI_ARGS_((Tcl_Interp *interp,
+ int objIndex, char *fileName,
+ Tcl_Obj **attributePtrPtr));
+static int SetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp,
+ int objIndex, char *fileName,
+ Tcl_Obj *attributePtr));
+static int CannotSetAttribute _ANSI_ARGS_((Tcl_Interp *interp,
+ int objIndex, 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)(char *src, char *dst, DWORD attr, int type,
+ Tcl_DString *errorPtr);
+
+/*
+ * Declarations for local procedures defined in this file:
+ */
+
+static void AttributesPosixError _ANSI_ARGS_((Tcl_Interp *interp,
+ int objIndex, char *fileName, int getOrSet));
+static int ConvertFileNameFormat _ANSI_ARGS_((Tcl_Interp *interp,
+ int objIndex, char *fileName, int longShort,
+ Tcl_Obj **attributePtrPtr));
+static int TraversalCopy(char *src, char *dst, DWORD attr,
+ int type, Tcl_DString *errorPtr);
+static int TraversalDelete(char *src, char *dst, DWORD attr,
+ int type, Tcl_DString *errorPtr);
+static int TraverseWinTree(TraversalProc *traverseProc,
+ Tcl_DString *sourcePtr, Tcl_DString *destPtr,
+ Tcl_DString *errorPtr);
+
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclpRenameFile --
+ *
+ * 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 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: 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(
+ char *src, /* Pathname of file or dir to be renamed. */
+ char *dst) /* New pathname for file or directory. */
+{
+ DWORD srcAttr, dstAttr;
+
+ /*
+ * Would throw an exception under NT if one of the arguments is a
+ * char block device.
+ */
+
+ try {
+ if (MoveFile(src, dst) != FALSE) {
+ return TCL_OK;
+ }
+ } except (-1) {}
+
+ TclWinConvertError(GetLastError());
+
+ srcAttr = GetFileAttributes(src);
+ dstAttr = GetFileAttributes(dst);
+ if (srcAttr == (DWORD) -1) {
+ srcAttr = 0;
+ }
+ if (dstAttr == (DWORD) -1) {
+ dstAttr = 0;
+ }
+
+ if (errno == EBADF) {
+ errno = EACCES;
+ return TCL_ERROR;
+ }
+ if ((errno == EACCES) && (TclWinGetPlatformId() == VER_PLATFORM_WIN32s)) {
+ if ((srcAttr != 0) && (dstAttr != 0)) {
+ /*
+ * Win32s reports trying to overwrite an existing file or directory
+ * as EACCES.
+ */
+
+ errno = EEXIST;
+ }
+ }
+ if (errno == EACCES) {
+ decode:
+ if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) {
+ char srcPath[MAX_PATH], dstPath[MAX_PATH];
+ int srcArgc, dstArgc;
+ char **srcArgv, **dstArgv;
+ char *srcRest, *dstRest;
+ int size;
+
+ size = GetFullPathName(src, sizeof(srcPath), srcPath, &srcRest);
+ if ((size == 0) || (size > sizeof(srcPath))) {
+ return TCL_ERROR;
+ }
+ size = GetFullPathName(dst, sizeof(dstPath), dstPath, &dstRest);
+ if ((size == 0) || (size > sizeof(dstPath))) {
+ return TCL_ERROR;
+ }
+ if (srcRest == NULL) {
+ srcRest = srcPath + strlen(srcPath);
+ }
+ if (strnicmp(srcPath, dstPath, srcRest - srcPath) == 0) {
+ /*
+ * Trying to move a directory into itself.
+ */
+
+ errno = EINVAL;
+ return TCL_ERROR;
+ }
+ Tcl_SplitPath(srcPath, &srcArgc, &srcArgv);
+ Tcl_SplitPath(dstPath, &dstArgc, &dstArgv);
+ if (srcArgc == 1) {
+ /*
+ * They are trying to move a root directory. Whether
+ * or not it is across filesystems, this cannot be
+ * done.
+ */
+
+ errno = EINVAL;
+ } else if ((srcArgc > 0) && (dstArgc > 0) &&
+ (stricmp(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.
+ */
+
+ errno = 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 (errno == 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 (TclpRemoveDirectory(dst, 0, NULL) == TCL_OK) {
+ /*
+ * Now that that empty directory is gone, we can try
+ * renaming again. If that fails, we'll put this empty
+ * directory back, for completeness.
+ */
+
+ if (MoveFile(src, dst) != FALSE) {
+ return TCL_OK;
+ }
+
+ /*
+ * Some new error has occurred. Don't know what it
+ * could be, but report this one.
+ */
+
+ TclWinConvertError(GetLastError());
+ CreateDirectory(dst, NULL);
+ SetFileAttributes(dst, dstAttr);
+ if (errno == EACCES) {
+ /*
+ * Decode the EACCES to a more meaningful error.
+ */
+
+ goto decode;
+ }
+ }
+ } else { /* (dstAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */
+ errno = ENOTDIR;
+ }
+ } else { /* (srcAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */
+ if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) {
+ errno = 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.
+ */
+
+ char tempName[MAX_PATH];
+ int result, size;
+ char *rest;
+
+ size = GetFullPathName(dst, sizeof(tempName), tempName, &rest);
+ if ((size == 0) || (size > sizeof(tempName)) || (rest == NULL)) {
+ return TCL_ERROR;
+ }
+ *rest = '\0';
+ result = TCL_ERROR;
+ if (GetTempFileName(tempName, "tclr", 0, tempName) != 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.
+ */
+
+ DeleteFile(tempName);
+ if (MoveFile(dst, tempName) != FALSE) {
+ if (MoveFile(src, dst) != FALSE) {
+ SetFileAttributes(tempName, FILE_ATTRIBUTE_NORMAL);
+ DeleteFile(tempName);
+ return TCL_OK;
+ } else {
+ DeleteFile(dst);
+ MoveFile(tempName, dst);
+ }
+ }
+
+ /*
+ * Can't backup dst file or move src file. Return that
+ * error. Could happen if an open file refers to dst.
+ */
+
+ TclWinConvertError(GetLastError());
+ if (errno == EACCES) {
+ /*
+ * Decode the EACCES to a more meaningful error.
+ */
+
+ goto decode;
+ }
+ }
+ return result;
+ }
+ }
+ }
+ return TCL_ERROR;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclpCopyFile --
+ *
+ * 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(
+ char *src, /* Pathname of file to be copied. */
+ char *dst) /* Pathname of file to copy to. */
+{
+ /*
+ * Would throw an exception under NT if one of the arguments is a char
+ * block device.
+ */
+
+ try {
+ if (CopyFile(src, dst, 0) != FALSE) {
+ return TCL_OK;
+ }
+ } except (-1) {}
+
+ TclWinConvertError(GetLastError());
+ if (errno == EBADF) {
+ errno = EACCES;
+ return TCL_ERROR;
+ }
+ if (errno == EACCES) {
+ DWORD srcAttr, dstAttr;
+
+ srcAttr = GetFileAttributes(src);
+ dstAttr = GetFileAttributes(dst);
+ if (srcAttr != (DWORD) -1) {
+ if (dstAttr == (DWORD) -1) {
+ dstAttr = 0;
+ }
+ if ((srcAttr & FILE_ATTRIBUTE_DIRECTORY) ||
+ (dstAttr & FILE_ATTRIBUTE_DIRECTORY)) {
+ errno = EISDIR;
+ }
+ if (dstAttr & FILE_ATTRIBUTE_READONLY) {
+ SetFileAttributes(dst, dstAttr & ~FILE_ATTRIBUTE_READONLY);
+ if (CopyFile(src, dst, 0) != FALSE) {
+ return TCL_OK;
+ }
+ /*
+ * Still can't copy onto dst. Return that error, and
+ * restore attributes of dst.
+ */
+
+ TclWinConvertError(GetLastError());
+ SetFileAttributes(dst, dstAttr);
+ }
+ }
+ }
+ return TCL_ERROR;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclpDeleteFile --
+ *
+ * Removes a single file (not a directory).
+ *
+ * Results:
+ * If the file was successfully deleted, returns TCL_OK. Otherwise
+ * the return value is TCL_ERROR and errno is set to indicate the
+ * error. Some possible values for errno are:
+ *
+ * EACCES: a parent directory can't be read and/or written.
+ * EISDIR: path is a directory.
+ * ENOENT: path doesn't exist or is "".
+ *
+ * EACCES: exists an open file already referring to path.
+ * EACCES: path is a char device (nul:, com1:, etc.)
+ *
+ * Side effects:
+ * The file is deleted, even if it is read-only.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+TclpDeleteFile(
+ char *path) /* Pathname of file to be removed. */
+{
+ DWORD attr;
+
+ if (DeleteFile(path) != FALSE) {
+ return TCL_OK;
+ }
+ TclWinConvertError(GetLastError());
+ if (path[0] == '\0') {
+ /*
+ * Win32s thinks that "" is the same as "." and then reports EISDIR
+ * instead of ENOENT.
+ */
+
+ errno = ENOENT;
+ } else if (errno == EACCES) {
+ attr = GetFileAttributes(path);
+ if (attr != (DWORD) -1) {
+ if (attr & FILE_ATTRIBUTE_DIRECTORY) {
+ /*
+ * Windows NT reports removing a directory as EACCES instead
+ * of EISDIR.
+ */
+
+ errno = EISDIR;
+ } else if (attr & FILE_ATTRIBUTE_READONLY) {
+ SetFileAttributes(path, attr & ~FILE_ATTRIBUTE_READONLY);
+ if (DeleteFile(path) != FALSE) {
+ return TCL_OK;
+ }
+ TclWinConvertError(GetLastError());
+ SetFileAttributes(path, attr);
+ }
+ }
+ } else if (errno == ENOENT) {
+ attr = GetFileAttributes(path);
+ if (attr != (DWORD) -1) {
+ if (attr & FILE_ATTRIBUTE_DIRECTORY) {
+ /*
+ * Windows 95 reports removing a directory as ENOENT instead
+ * of EISDIR.
+ */
+
+ errno = EISDIR;
+ }
+ }
+ } else if (errno == EINVAL) {
+ /*
+ * Windows NT reports removing a char device as EINVAL instead of
+ * EACCES.
+ */
+
+ errno = 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(
+ char *path) /* Pathname of directory to create */
+{
+ int error;
+
+ if (CreateDirectory(path, NULL) == 0) {
+ error = GetLastError();
+ if (TclWinGetPlatformId() == VER_PLATFORM_WIN32s) {
+ if ((error == ERROR_ACCESS_DENIED)
+ && (GetFileAttributes(path) != (DWORD) -1)) {
+ error = ERROR_FILE_EXISTS;
+ }
+ }
+ 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(
+ char *src, /* Pathname of directory to be copied. */
+ char *dst, /* Pathname of target directory. */
+ Tcl_DString *errorPtr) /* If non-NULL, initialized DString for
+ * error reporting. */
+{
+ int result;
+ Tcl_DString srcBuffer;
+ Tcl_DString dstBuffer;
+
+ Tcl_DStringInit(&srcBuffer);
+ Tcl_DStringInit(&dstBuffer);
+ Tcl_DStringAppend(&srcBuffer, src, -1);
+ Tcl_DStringAppend(&dstBuffer, dst, -1);
+ result = TraverseWinTree(TraversalCopy, &srcBuffer, &dstBuffer,
+ errorPtr);
+ Tcl_DStringFree(&srcBuffer);
+ Tcl_DStringFree(&dstBuffer);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpRemoveDirectory --
+ *
+ * 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(
+ char *path, /* Pathname of directory to be removed. */
+ int recursive, /* If non-zero, removes directories that
+ * are nonempty. Otherwise, will only remove
+ * empty directories. */
+ Tcl_DString *errorPtr) /* If non-NULL, initialized DString for
+ * error reporting. */
+{
+ int result;
+ Tcl_DString buffer;
+ DWORD attr;
+
+ if (RemoveDirectory(path) != FALSE) {
+ return TCL_OK;
+ }
+ TclWinConvertError(GetLastError());
+ if (path[0] == '\0') {
+ /*
+ * Win32s thinks that "" is the same as "." and then reports EACCES
+ * instead of ENOENT.
+ */
+
+ errno = ENOENT;
+ }
+ if (errno == EACCES) {
+ attr = GetFileAttributes(path);
+ if (attr != (DWORD) -1) {
+ if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
+ /*
+ * Windows 95 reports calling RemoveDirectory on a file as an
+ * EACCES, not an ENOTDIR.
+ */
+
+ errno = ENOTDIR;
+ goto end;
+ }
+
+ if (attr & FILE_ATTRIBUTE_READONLY) {
+ attr &= ~FILE_ATTRIBUTE_READONLY;
+ if (SetFileAttributes(path, attr) == FALSE) {
+ goto end;
+ }
+ if (RemoveDirectory(path) != FALSE) {
+ return TCL_OK;
+ }
+ TclWinConvertError(GetLastError());
+ SetFileAttributes(path, 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) {
+ HANDLE handle;
+ WIN32_FIND_DATA data;
+ Tcl_DString buffer;
+ char *find;
+ int len;
+
+ Tcl_DStringInit(&buffer);
+ find = Tcl_DStringAppend(&buffer, path, -1);
+ len = Tcl_DStringLength(&buffer);
+ if ((len > 0) && (find[len - 1] != '\\')) {
+ Tcl_DStringAppend(&buffer, "\\", 1);
+ }
+ find = Tcl_DStringAppend(&buffer, "*.*", 3);
+ handle = FindFirstFile(find, &data);
+ if (handle != INVALID_HANDLE_VALUE) {
+ while (1) {
+ if ((strcmp(data.cFileName, ".") != 0)
+ && (strcmp(data.cFileName, "..") != 0)) {
+ /*
+ * Found something in this directory.
+ */
+
+ errno = EEXIST;
+ break;
+ }
+ if (FindNextFile(handle, &data) == FALSE) {
+ break;
+ }
+ }
+ FindClose(handle);
+ }
+ Tcl_DStringFree(&buffer);
+ }
+ }
+ }
+ if (errno == ENOTEMPTY) {
+ /*
+ * The caller depends on EEXIST to signify that the directory is
+ * not empty, not ENOTEMPTY.
+ */
+
+ errno = EEXIST;
+ }
+ if ((recursive != 0) && (errno == EEXIST)) {
+ /*
+ * The directory is nonempty, but the recursive flag has been
+ * specified, so we recursively remove all the files in the directory.
+ */
+
+ Tcl_DStringInit(&buffer);
+ Tcl_DStringAppend(&buffer, path, -1);
+ result = TraverseWinTree(TraversalDelete, &buffer, NULL, errorPtr);
+ Tcl_DStringFree(&buffer);
+ return result;
+ }
+
+ end:
+ if (errorPtr != NULL) {
+ Tcl_DStringAppend(errorPtr, path, -1);
+ }
+ 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. */
+ Tcl_DString *targetPtr, /* Pathname of directory to traverse in
+ * parallel with source directory. */
+ Tcl_DString *errorPtr) /* If non-NULL, an initialized DString for
+ * error reporting. */
+{
+ DWORD sourceAttr;
+ char *source, *target, *errfile;
+ int result, sourceLen, targetLen, sourceLenOriginal, targetLenOriginal;
+ HANDLE handle;
+ WIN32_FIND_DATA data;
+
+ result = TCL_OK;
+ source = Tcl_DStringValue(sourcePtr);
+ sourceLenOriginal = Tcl_DStringLength(sourcePtr);
+ if (targetPtr != NULL) {
+ target = Tcl_DStringValue(targetPtr);
+ targetLenOriginal = Tcl_DStringLength(targetPtr);
+ } else {
+ target = NULL;
+ targetLenOriginal = 0;
+ }
+
+ errfile = NULL;
+
+ sourceAttr = GetFileAttributes(source);
+ if (sourceAttr == (DWORD) -1) {
+ errfile = source;
+ goto end;
+ }
+ if ((sourceAttr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
+ /*
+ * Process the regular file
+ */
+
+ return (*traverseProc)(source, target, sourceAttr, DOTREE_F, errorPtr);
+ }
+
+ /*
+ * When given the pathname of the form "c:\" (one that already ends
+ * with a backslash), must make sure not to add another "\" to the end
+ * otherwise it will try to access a network drive.
+ */
+
+ sourceLen = sourceLenOriginal;
+ if ((sourceLen > 0) && (source[sourceLen - 1] != '\\')) {
+ Tcl_DStringAppend(sourcePtr, "\\", 1);
+ sourceLen++;
+ }
+ source = Tcl_DStringAppend(sourcePtr, "*.*", 3);
+ handle = FindFirstFile(source, &data);
+ Tcl_DStringSetLength(sourcePtr, sourceLen);
+ if (handle == INVALID_HANDLE_VALUE) {
+ /*
+ * Can't read directory
+ */
+
+ TclWinConvertError(GetLastError());
+ errfile = source;
+ goto end;
+ }
+
+ result = (*traverseProc)(source, target, sourceAttr, DOTREE_PRED, errorPtr);
+ if (result != TCL_OK) {
+ FindClose(handle);
+ return result;
+ }
+
+ if (targetPtr != NULL) {
+ targetLen = targetLenOriginal;
+ if ((targetLen > 0) && (target[targetLen - 1] != '\\')) {
+ target = Tcl_DStringAppend(targetPtr, "\\", 1);
+ targetLen++;
+ }
+ }
+
+ while (1) {
+ if ((strcmp(data.cFileName, ".") != 0)
+ && (strcmp(data.cFileName, "..") != 0)) {
+ /*
+ * Append name after slash, and recurse on the file.
+ */
+
+ Tcl_DStringAppend(sourcePtr, data.cFileName, -1);
+ if (targetPtr != NULL) {
+ Tcl_DStringAppend(targetPtr, data.cFileName, -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);
+ }
+ }
+ if (FindNextFile(handle, &data) == FALSE) {
+ break;
+ }
+ }
+ FindClose(handle);
+
+ /*
+ * Strip off the trailing slash we added
+ */
+
+ Tcl_DStringSetLength(sourcePtr, sourceLenOriginal);
+ source = Tcl_DStringValue(sourcePtr);
+ if (targetPtr != NULL) {
+ Tcl_DStringSetLength(targetPtr, targetLenOriginal);
+ target = Tcl_DStringValue(targetPtr);
+ }
+
+ if (result == TCL_OK) {
+ /*
+ * Call traverseProc() on a directory after visiting all the
+ * files in that directory.
+ */
+
+ result = (*traverseProc)(source, target, sourceAttr,
+ DOTREE_POSTD, errorPtr);
+ }
+ end:
+ if (errfile != NULL) {
+ TclWinConvertError(GetLastError());
+ if (errorPtr != NULL) {
+ Tcl_DStringAppend(errorPtr, errfile, -1);
+ }
+ 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(
+ char *src, /* Source pathname to copy. */
+ char *dst, /* Destination pathname of copy. */
+ DWORD srcAttr, /* File attributes for src. */
+ int type, /* Reason for call - see TraverseWinTree() */
+ Tcl_DString *errorPtr) /* If non-NULL, initialized DString for
+ * error return. */
+{
+ switch (type) {
+ case DOTREE_F:
+ if (TclpCopyFile(src, dst) == TCL_OK) {
+ return TCL_OK;
+ }
+ break;
+
+ case DOTREE_PRED:
+ if (TclpCreateDirectory(dst) == TCL_OK) {
+ if (SetFileAttributes(dst, srcAttr) != FALSE) {
+ return TCL_OK;
+ }
+ TclWinConvertError(GetLastError());
+ }
+ break;
+
+ case DOTREE_POSTD:
+ return TCL_OK;
+
+ }
+
+ /*
+ * There shouldn't be a problem with src, because we already
+ * checked it to get here.
+ */
+
+ if (errorPtr != NULL) {
+ Tcl_DStringAppend(errorPtr, dst, -1);
+ }
+ 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(
+ char *src, /* Source pathname. */
+ char *ignore, /* Destination pathname (not used). */
+ DWORD srcAttr, /* File attributes for src (not used). */
+ int type, /* Reason for call - see TraverseWinTree(). */
+ Tcl_DString *errorPtr) /* If non-NULL, initialized DString for
+ * error return. */
+{
+ switch (type) {
+ case DOTREE_F:
+ if (TclpDeleteFile(src) == TCL_OK) {
+ return TCL_OK;
+ }
+ break;
+
+ case DOTREE_PRED:
+ return TCL_OK;
+
+ case DOTREE_POSTD:
+ if (TclpRemoveDirectory(src, 0, NULL) == TCL_OK) {
+ return TCL_OK;
+ }
+ break;
+
+ }
+
+ if (errorPtr != NULL) {
+ Tcl_DStringAppend(errorPtr, src, -1);
+ }
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * AttributesPosixError --
+ *
+ * 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
+AttributesPosixError(
+ Tcl_Interp *interp, /* The interp that has the error */
+ int objIndex, /* The attribute which caused the problem. */
+ char *fileName, /* The name of the file which caused the
+ * error. */
+ int getOrSet) /* 0 for get; 1 for set */
+{
+ TclWinConvertError(GetLastError());
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "cannot ", getOrSet ? "set" : "get", " attribute \"",
+ tclpFileAttrStrings[objIndex], "\" for file \"", 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. */
+ char *fileName, /* The name of the file. */
+ Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
+{
+ DWORD result = GetFileAttributes(fileName);
+
+ if (result == 0xFFFFFFFF) {
+ AttributesPosixError(interp, objIndex, fileName, 0);
+ return TCL_ERROR;
+ }
+
+ *attributePtrPtr = Tcl_NewBooleanObj(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. */
+ 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. */
+{
+ HANDLE findHandle;
+ WIN32_FIND_DATA findData;
+ int pathArgc, i;
+ char **pathArgv, **newPathArgv;
+ char *currentElement, *resultStr;
+ Tcl_DString resultDString;
+ int result = TCL_OK;
+
+ Tcl_SplitPath(fileName, &pathArgc, &pathArgv);
+ newPathArgv = (char **) ckalloc(pathArgc * sizeof(char *));
+
+ i = 0;
+ if ((pathArgv[0][0] == '/')
+ || ((strlen(pathArgv[0]) == 3) && (pathArgv[0][1] == ':'))) {
+ newPathArgv[0] = (char *) ckalloc(strlen(pathArgv[0]) + 1);
+ strcpy(newPathArgv[0], pathArgv[0]);
+ i = 1;
+ }
+ for ( ; i < pathArgc; i++) {
+ if (strcmp(pathArgv[i], ".") == 0) {
+ currentElement = ckalloc(2);
+ strcpy(currentElement, ".");
+ } else if (strcmp(pathArgv[i], "..") == 0) {
+ currentElement = ckalloc(3);
+ strcpy(currentElement, "..");
+ } else {
+ int useLong;
+
+ Tcl_DStringInit(&resultDString);
+ resultStr = Tcl_JoinPath(i + 1, pathArgv, &resultDString);
+ findHandle = FindFirstFile(resultStr, &findData);
+ if (findHandle == INVALID_HANDLE_VALUE) {
+ pathArgc = i - 1;
+ AttributesPosixError(interp, objIndex, fileName, 0);
+ result = TCL_ERROR;
+ Tcl_DStringFree(&resultDString);
+ goto cleanup;
+ }
+ if (longShort) {
+ if (findData.cFileName[0] != '\0') {
+ useLong = 1;
+ } else {
+ useLong = 0;
+ }
+ } else {
+ if (findData.cAlternateFileName[0] == '\0') {
+ useLong = 1;
+ } else {
+ useLong = 0;
+ }
+ }
+ if (useLong) {
+ currentElement = ckalloc(strlen(findData.cFileName) + 1);
+ strcpy(currentElement, findData.cFileName);
+ } else {
+ currentElement = ckalloc(strlen(findData.cAlternateFileName)
+ + 1);
+ strcpy(currentElement, findData.cAlternateFileName);
+ }
+ Tcl_DStringFree(&resultDString);
+ FindClose(findHandle);
+ }
+ newPathArgv[i] = currentElement;
+ }
+
+ Tcl_DStringInit(&resultDString);
+ resultStr = Tcl_JoinPath(pathArgc, newPathArgv, &resultDString);
+ *attributePtrPtr = Tcl_NewStringObj(resultStr, Tcl_DStringLength(&resultDString));
+ Tcl_DStringFree(&resultDString);
+
+cleanup:
+ for (i = 0; i < pathArgc; i++) {
+ ckfree(newPathArgv[i]);
+ }
+ ckfree((char *) newPathArgv);
+ 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. */
+ 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. */
+ 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. */
+ char *fileName, /* The name of the file. */
+ Tcl_Obj *attributePtr) /* The new value of the attribute. */
+{
+ DWORD fileAttributes = GetFileAttributes(fileName);
+ int yesNo;
+ int result;
+
+ if (fileAttributes == 0xFFFFFFFF) {
+ AttributesPosixError(interp, objIndex, fileName, 1);
+ return TCL_ERROR;
+ }
+
+ result = Tcl_GetBooleanFromObj(interp, attributePtr, &yesNo);
+ if (result != TCL_OK) {
+ return result;
+ }
+
+ if (yesNo) {
+ fileAttributes |= (attributeArray[objIndex]);
+ } else {
+ fileAttributes &= ~(attributeArray[objIndex]);
+ }
+
+ if (!SetFileAttributes(fileName, fileAttributes)) {
+ AttributesPosixError(interp, objIndex, fileName, 1);
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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. */
+ 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 to which to pass the volume list */
+{
+ Tcl_Obj *resultPtr, *elemPtr;
+ char buf[4];
+ int i;
+
+ resultPtr = Tcl_GetObjResult(interp);
+
+ buf[1] = ':';
+ buf[2] = '/';
+ buf[3] = '\0';
+
+ /*
+ * On Win32s:
+ * GetLogicalDriveStrings() isn't implemented.
+ * GetLogicalDrives() returns incorrect information.
+ */
+
+ for (i = 0; i < 26; i++) {
+ buf[0] = (char) ('a' + i);
+ if (GetVolumeInformation(buf, NULL, 0, NULL, NULL, NULL, NULL, 0)
+ || (GetLastError() == ERROR_NOT_READY)) {
+ elemPtr = Tcl_NewStringObj(buf, -1);
+ Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr);
+ }
+ }
+ return TCL_OK;
+}
diff --git a/win/tclWinFile.c b/win/tclWinFile.c
new file mode 100644
index 0000000..9d97b02
--- /dev/null
+++ b/win/tclWinFile.c
@@ -0,0 +1,647 @@
+/*
+ * 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-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.
+ *
+ * SCCS: @(#) tclWinFile.c 1.45 97/10/29 19:08:35
+ */
+
+#include "tclWinInt.h"
+#include <sys/stat.h>
+#include <shlobj.h>
+
+/*
+ * The variable below caches the name of the current working directory
+ * in order to avoid repeated calls to getcwd. The string is malloc-ed.
+ * NULL means the cache needs to be refreshed.
+ */
+
+static char *currentDir = NULL;
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FindExecutable --
+ *
+ * This procedure computes the absolute path name of the current
+ * application, given its argv[0] value.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The variable tclExecutableName gets filled in with the file
+ * name for the application, if we figured it out. If we couldn't
+ * figure it out, Tcl_FindExecutable is set to NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_FindExecutable(argv0)
+ char *argv0; /* The value of the application's argv[0]. */
+{
+ Tcl_DString buffer;
+ int length;
+
+ Tcl_DStringInit(&buffer);
+
+ if (tclExecutableName != NULL) {
+ ckfree(tclExecutableName);
+ tclExecutableName = NULL;
+ }
+
+ /*
+ * Under Windows we ignore argv0, and return the path for the file used to
+ * create this process.
+ */
+
+ Tcl_DStringSetLength(&buffer, MAX_PATH+1);
+ length = GetModuleFileName(NULL, Tcl_DStringValue(&buffer), MAX_PATH+1);
+ if (length > 0) {
+ tclExecutableName = (char *) ckalloc((unsigned) (length + 1));
+ strcpy(tclExecutableName, Tcl_DStringValue(&buffer));
+ }
+ Tcl_DStringFree(&buffer);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclMatchFiles --
+ *
+ * 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 interp->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
+TclMatchFiles(interp, separators, dirPtr, pattern, tail)
+ 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. */
+{
+ char drivePattern[4] = "?:\\";
+ char *newPattern, *p, *dir, *root, c;
+ char *src, *dest;
+ int length, matchDotFiles;
+ int result = TCL_OK;
+ int baseLength = Tcl_DStringLength(dirPtr);
+ Tcl_DString buffer;
+ DWORD atts, volFlags;
+ HANDLE handle;
+ WIN32_FIND_DATA data;
+ BOOL found;
+
+ /*
+ * Convert the path to normalized form since some interfaces only
+ * accept backslashes. Also, ensure that the directory ends with a
+ * separator character.
+ */
+
+ Tcl_DStringInit(&buffer);
+ if (baseLength == 0) {
+ Tcl_DStringAppend(&buffer, ".", 1);
+ } else {
+ Tcl_DStringAppend(&buffer, Tcl_DStringValue(dirPtr),
+ Tcl_DStringLength(dirPtr));
+ }
+ for (p = Tcl_DStringValue(&buffer); *p != '\0'; p++) {
+ if (*p == '/') {
+ *p = '\\';
+ }
+ }
+ p--;
+ if (*p != '\\' && *p != ':') {
+ Tcl_DStringAppend(&buffer, "\\", 1);
+ }
+ dir = Tcl_DStringValue(&buffer);
+
+ /*
+ * First verify that the specified path is actually a directory.
+ */
+
+ atts = GetFileAttributes(dir);
+ if ((atts == 0xFFFFFFFF) || ((atts & FILE_ATTRIBUTE_DIRECTORY) == 0)) {
+ Tcl_DStringFree(&buffer);
+ 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 = GetVolumeInformation(NULL, NULL, 0, NULL,
+ NULL, &volFlags, NULL, 0);
+ break;
+ case TCL_PATH_VOLUME_RELATIVE:
+ if (*dir == '\\') {
+ root = NULL;
+ } else {
+ root = drivePattern;
+ *root = *dir;
+ }
+ found = GetVolumeInformation(root, NULL, 0, NULL,
+ NULL, &volFlags, NULL, 0);
+ break;
+ case TCL_PATH_ABSOLUTE:
+ if (dir[1] == ':') {
+ root = drivePattern;
+ *root = *dir;
+ found = GetVolumeInformation(root, NULL, 0, NULL,
+ NULL, &volFlags, NULL, 0);
+ } else if (dir[1] == '\\') {
+ p = strchr(dir+2, '\\');
+ p = strchr(p+1, '\\');
+ p++;
+ c = *p;
+ *p = 0;
+ found = GetVolumeInformation(dir, NULL, 0, NULL,
+ NULL, &volFlags, NULL, 0);
+ *p = c;
+ }
+ break;
+ }
+
+ if (!found) {
+ Tcl_DStringFree(&buffer);
+ TclWinConvertError(GetLastError());
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "couldn't read volume information for \"",
+ dirPtr->string, "\": ", Tcl_PosixError(interp), (char *) NULL);
+ return TCL_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.
+ */
+
+ length = tail - pattern;
+ newPattern = ckalloc(length+1);
+ for (src = pattern, dest = newPattern; src < tail; src++, dest++) {
+ *dest = (char) tolower(*src);
+ }
+ *dest = '\0';
+
+ /*
+ * We need to check all files in the directory, so append a *.*
+ * to the path.
+ */
+
+
+ dir = Tcl_DStringAppend(&buffer, "*.*", 3);
+
+ /*
+ * Now open the directory for reading and iterate over the contents.
+ */
+
+ handle = FindFirstFile(dir, &data);
+ Tcl_DStringFree(&buffer);
+
+ if (handle == INVALID_HANDLE_VALUE) {
+ TclWinConvertError(GetLastError());
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "couldn't read directory \"",
+ dirPtr->string, "\": ", Tcl_PosixError(interp), (char *) NULL);
+ ckfree(newPattern);
+ return TCL_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.
+ */
+
+ Tcl_DStringInit(&buffer);
+ for (found = 1; found; found = FindNextFile(handle, &data)) {
+ char *matchResult;
+
+ /*
+ * Ignore hidden files.
+ */
+
+ if (!matchDotFiles && (data.cFileName[0] == '.')) {
+ continue;
+ }
+
+ /*
+ * 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 return the lower case form of the
+ * name, otherwise we return the system form.
+ */
+
+ matchResult = NULL;
+ Tcl_DStringSetLength(&buffer, 0);
+ Tcl_DStringAppend(&buffer, data.cFileName, -1);
+ for (p = buffer.string; *p != '\0'; p++) {
+ *p = (char) tolower(*p);
+ }
+ if (Tcl_StringMatch(buffer.string, newPattern)) {
+ if (volFlags & FS_CASE_IS_PRESERVED) {
+ matchResult = data.cFileName;
+ } else {
+ matchResult = buffer.string;
+ }
+ }
+
+ if (matchResult == 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.
+ */
+
+ Tcl_DStringSetLength(dirPtr, baseLength);
+ Tcl_DStringAppend(dirPtr, matchResult, -1);
+ if (tail == NULL) {
+ Tcl_AppendElement(interp, dirPtr->string);
+ } else {
+ atts = GetFileAttributes(dirPtr->string);
+ if (atts & FILE_ATTRIBUTE_DIRECTORY) {
+ Tcl_DStringAppend(dirPtr, "/", 1);
+ result = TclDoGlob(interp, separators, dirPtr, tail);
+ if (result != TCL_OK) {
+ break;
+ }
+ }
+ }
+ }
+
+ Tcl_DStringFree(&buffer);
+ FindClose(handle);
+ ckfree(newPattern);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclChdir --
+ *
+ * Change the current working directory.
+ *
+ * Results:
+ * The result is a standard Tcl result. If an error occurs and
+ * interp isn't NULL, an error message is left in interp->result.
+ *
+ * Side effects:
+ * The working directory for this application is changed. Also
+ * the cache maintained used by TclGetCwd is deallocated and
+ * set to NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclChdir(interp, dirName)
+ Tcl_Interp *interp; /* If non NULL, used for error reporting. */
+ char *dirName; /* Path to new working directory. */
+{
+ if (currentDir != NULL) {
+ ckfree(currentDir);
+ currentDir = NULL;
+ }
+ if (!SetCurrentDirectory(dirName)) {
+ TclWinConvertError(GetLastError());
+ if (interp != NULL) {
+ Tcl_AppendResult(interp, "couldn't change working directory to \"",
+ dirName, "\": ", Tcl_PosixError(interp), (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGetCwd --
+ *
+ * Return the path name of the current working directory.
+ *
+ * Results:
+ * The result is the full path name of the current working
+ * directory, or NULL if an error occurred while figuring it
+ * out. If an error occurs and interp isn't NULL, an error
+ * message is left in interp->result.
+ *
+ * Side effects:
+ * The path name is cached to avoid having to recompute it
+ * on future calls; if it is already cached, the cached
+ * value is returned.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+TclGetCwd(interp)
+ Tcl_Interp *interp; /* If non NULL, used for error reporting. */
+{
+ static char buffer[MAXPATHLEN+1];
+ char *bufPtr, *p;
+
+ if (currentDir == NULL) {
+ if (GetCurrentDirectory(MAXPATHLEN+1, buffer) == 0) {
+ TclWinConvertError(GetLastError());
+ if (interp != NULL) {
+ if (errno == ERANGE) {
+ Tcl_SetResult(interp,
+ "working directory name is too long",
+ TCL_STATIC);
+ } else {
+ Tcl_AppendResult(interp,
+ "error getting working directory name: ",
+ Tcl_PosixError(interp), (char *) NULL);
+ }
+ }
+ return NULL;
+ }
+ /*
+ * Watch for the wierd Windows '95 c:\\UNC syntax.
+ */
+
+ if (buffer[0] != '\0' && buffer[1] == ':' && buffer[2] == '\\'
+ && buffer[3] == '\\') {
+ bufPtr = &buffer[2];
+ } else {
+ bufPtr = buffer;
+ }
+
+ /*
+ * Convert to forward slashes for easier use in scripts.
+ */
+
+ for (p = bufPtr; *p != '\0'; p++) {
+ if (*p == '\\') {
+ *p = '/';
+ }
+ }
+ }
+ return bufPtr;
+}
+
+#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
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclWinStat, TclWinLstat --
+ *
+ * These functions replace the library versions of stat and lstat.
+ *
+ * The stat and lstat functions provided by some Windows compilers
+ * are incomplete. Ideally, a complete rewrite of stat would go
+ * here; now, the only fix is that stat("c:") used to return an
+ * error instead infor for current dir on specified drive.
+ *
+ * Results:
+ * See stat documentation.
+ *
+ * Side effects:
+ * See stat documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclWinStat(path, buf)
+ CONST char *path; /* Path of file to stat (in current CP). */
+ struct stat *buf; /* Filled with results of stat call. */
+{
+ char name[4];
+ int result;
+
+ if ((strlen(path) == 2) && (path[1] == ':')) {
+ strcpy(name, path);
+ name[2] = '.';
+ name[3] = '\0';
+ path = name;
+ }
+
+#undef stat
+
+ result = stat(path, buf);
+
+#ifndef _MSC_VER
+
+ /*
+ * 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
+
+ return result;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclWinAccess --
+ *
+ * This function replaces the library version of access.
+ *
+ * The library version of access returns that all files have execute
+ * permission.
+ *
+ * Results:
+ * See access documentation.
+ *
+ * Side effects:
+ * See access documentation.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+TclWinAccess(
+ CONST char *path, /* Path of file to access (in current CP). */
+ int mode) /* Permission setting. */
+{
+ int result;
+ CONST char *p;
+
+#undef access
+
+ result = access(path, mode);
+
+ if (result == 0) {
+ if (mode & 1) {
+ if (GetFileAttributes(path) & 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;
+ }
+ }
+ errno = EACCES;
+ return -1;
+ }
+ }
+ return result;
+}
+
diff --git a/win/tclWinInit.c b/win/tclWinInit.c
new file mode 100644
index 0000000..be8dbbd
--- /dev/null
+++ b/win/tclWinInit.c
@@ -0,0 +1,394 @@
+/*
+ * tclWinInit.c --
+ *
+ * Contains the Windows-specific interpreter initialization functions.
+ *
+ * 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.
+ *
+ * SCCS: @(#) tclWinInit.c 1.32 97/06/24 17:28:26
+ */
+
+#include "tclInt.h"
+#include "tclPort.h"
+#include <winreg.h>
+#include <winnt.h>
+#include <winbase.h>
+
+/*
+ * 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"
+};
+
+/*
+ * The following string is the startup script executed in new
+ * interpreters. It looks on disk in several different directories
+ * for a script "init.tcl" that is compatible with this version
+ * of Tcl. The init.tcl script does all of the real work of
+ * initialization.
+ */
+
+static char *initScript =
+"proc init {} {\n\
+ global tcl_library tcl_platform tcl_version tcl_patchLevel env errorInfo\n\
+ global tcl_pkgPath\n\
+ rename init {}\n\
+ set errors {}\n\
+ proc tcl_envTraceProc {lo n1 n2 op} {\n\
+ global env\n\
+ set x $env($n2)\n\
+ set env($lo) $x\n\
+ set env([string toupper $lo]) $x\n\
+ }\n\
+ foreach p [array names env] {\n\
+ set u [string toupper $p]\n\
+ if {$u != $p} {\n\
+ switch -- $u {\n\
+ COMSPEC -\n\
+ PATH {\n\
+ if {![info exists env($u)]} {\n\
+ set env($u) $env($p)\n\
+ }\n\
+ trace variable env($p) w [list tcl_envTraceProc $p]\n\
+ trace variable env($u) w [list tcl_envTraceProc $p]\n\
+ }\n\
+ }\n\
+ }\n\
+ }\n\
+ if {![info exists env(COMSPEC)]} {\n\
+ if {$tcl_platform(os) == {Windows NT}} {\n\
+ set env(COMSPEC) cmd.exe\n\
+ } else {\n\
+ set env(COMSPEC) command.com\n\
+ }\n\
+ } \n\
+ set dirs {}\n\
+ if {[info exists env(TCL_LIBRARY)]} {\n\
+ lappend dirs $env(TCL_LIBRARY)\n\
+ }\n\
+ lappend dirs $tcl_library\n\
+ lappend dirs [file join [file dirname [file dirname [info nameofexecutable]]] lib/tcl$tcl_version]\n\
+ if [string match {*[ab]*} $tcl_patchLevel] {\n\
+ set lib tcl$tcl_patchLevel\n\
+ } else {\n\
+ set lib tcl$tcl_version\n\
+ }\n\
+ lappend dirs [file join [file dirname [file dirname [pwd]]] $lib/library]\n\
+ lappend dirs [file join [file dirname [pwd]] library]\n\
+ foreach i $dirs {\n\
+ set tcl_library $i\n\
+ set tclfile [file join $i init.tcl]\n\
+ if {[file exists $tclfile]} {\n\
+ lappend tcl_pkgPath [file dirname $i]\n\
+ if ![catch {uplevel #0 [list source $tclfile]} msg] {\n\
+ return\n\
+ } else {\n\
+ append errors \"$tclfile: $msg\n$errorInfo\n\"\n\
+ }\n\
+ }\n\
+ }\n\
+ set msg \"Can't find a usable init.tcl in the following directories: \n\"\n\
+ append msg \" $dirs\n\n\"\n\
+ append msg \"$errors\n\n\"\n\
+ append msg \"This probably means that Tcl wasn't installed properly.\n\"\n\
+ error $msg\n\
+}\n\
+init\n";
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPlatformInit --
+ *
+ * Performs Windows-specific interpreter initialization related to the
+ * tcl_library variable. Also sets up the HOME environment variable
+ * if it is not already set.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Sets "tcl_library" and "env(HOME)" Tcl variables
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclPlatformInit(interp)
+ Tcl_Interp *interp;
+{
+ char *ptr;
+ char buffer[13];
+ Tcl_DString ds;
+ OSVERSIONINFO osInfo;
+ SYSTEM_INFO sysInfo;
+ int isWin32s; /* True if we are running under Win32s. */
+ OemId *oemId;
+ HKEY key;
+ DWORD size;
+
+ tclPlatform = TCL_PLATFORM_WINDOWS;
+
+ Tcl_DStringInit(&ds);
+
+ /*
+ * Find out what kind of system we are running on.
+ */
+
+ osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
+ GetVersionEx(&osInfo);
+
+ isWin32s = (osInfo.dwPlatformId == VER_PLATFORM_WIN32s);
+
+ /*
+ * Since Win32s doesn't support GetSystemInfo, we use a default value.
+ */
+
+ oemId = (OemId *) &sysInfo;
+ if (!isWin32s) {
+ GetSystemInfo(&sysInfo);
+ } else {
+ oemId->wProcessorArchitecture = PROCESSOR_ARCHITECTURE_INTEL;
+ }
+
+ /*
+ * Initialize the tcl_library variable from the registry.
+ */
+
+ if (!isWin32s) {
+ if ((RegOpenKeyEx(HKEY_LOCAL_MACHINE,
+ "Software\\Sun\\Tcl\\" TCL_VERSION, 0, KEY_READ, &key)
+ == ERROR_SUCCESS)
+ && (RegQueryValueEx(key, "Root", NULL, NULL, NULL, &size)
+ == ERROR_SUCCESS)) {
+ Tcl_DStringSetLength(&ds, size);
+ RegQueryValueEx(key, "Root", NULL, NULL,
+ (LPBYTE)Tcl_DStringValue(&ds), &size);
+ }
+ } else {
+ if ((RegOpenKeyEx(HKEY_CLASSES_ROOT,
+ "Software\\Sun\\Tcl\\" TCL_VERSION, 0, KEY_READ, &key)
+ == ERROR_SUCCESS)
+ && (RegQueryValueEx(key, "", NULL, NULL, NULL, &size)
+ == ERROR_SUCCESS)) {
+ Tcl_DStringSetLength(&ds, size);
+ RegQueryValueEx(key, "", NULL, NULL,
+ (LPBYTE) Tcl_DStringValue(&ds), &size);
+ }
+ }
+ Tcl_SetVar(interp, "tcl_library", Tcl_DStringValue(&ds), TCL_GLOBAL_ONLY);
+ if (Tcl_DStringLength(&ds) > 0) {
+ char *argv[3];
+ argv[0] = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
+ argv[1] = "lib";
+ argv[2] = NULL;
+ Tcl_DStringSetLength(&ds, 0);
+ Tcl_SetVar(interp, "tcl_pkgPath", Tcl_JoinPath(2, argv, &ds),
+ TCL_GLOBAL_ONLY|TCL_LIST_ELEMENT);
+ argv[1] = "lib/tcl" TCL_VERSION;
+ Tcl_DStringSetLength(&ds, 0);
+ Tcl_SetVar(interp, "tcl_library", Tcl_JoinPath(2, argv, &ds),
+ 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);
+ }
+ sprintf(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);
+ }
+
+ /*
+ * Set up the HOME environment variable from the HOMEDRIVE & HOMEPATH
+ * environment variables, if necessary.
+ */
+
+ ptr = Tcl_GetVar2(interp, "env", "HOME", TCL_GLOBAL_ONLY);
+ if (ptr == NULL) {
+ Tcl_DStringSetLength(&ds, 0);
+ 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);
+ }
+ }
+
+ Tcl_DStringFree(&ds);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 interp->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. */
+{
+ return Tcl_Eval(interp, initScript);
+
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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_Write(errChannel, interp->result, -1);
+ Tcl_Write(errChannel, "\n", 1);
+ }
+ }
+ }
+ }
+ Tcl_DStringFree(&temp);
+ }
+}
diff --git a/win/tclWinInt.h b/win/tclWinInt.h
new file mode 100644
index 0000000..04e84d6
--- /dev/null
+++ b/win/tclWinInt.h
@@ -0,0 +1,38 @@
+/*
+ * 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.
+ *
+ * SCCS: @(#) tclWinInt.h 1.7 97/06/25 10:56:14
+ */
+
+#ifndef _TCLWININT
+#define _TCLWININT
+
+#ifndef _TCLINT
+#include "tclInt.h"
+#endif
+#ifndef _TCLPORT
+#include "tclPort.h"
+#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
+
+EXTERN int TclWinSynchSpawn(void *args, int type, void **trans,
+ Tcl_Pid *pidPtr);
+EXTERN int TclWinGetPlatformId(void);
+
+
+#endif /* _TCLWININT */
diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c
new file mode 100644
index 0000000..8106671
--- /dev/null
+++ b/win/tclWinLoad.c
@@ -0,0 +1,114 @@
+/*
+ * 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 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: @(#) tclWinLoad.c 1.6 96/02/15 11:54:07
+ */
+
+#include "tclInt.h"
+#include "tclPort.h"
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclLoadFile --
+ *
+ * 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 interp->result.
+ *
+ * Side effects:
+ * New code suddenly appears in memory.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr)
+ 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. */
+{
+ HINSTANCE handle;
+ char *buffer;
+
+ handle = TclWinLoadLibrary(fileName);
+ if (handle == NULL) {
+ Tcl_AppendResult(interp, "couldn't load file \"", fileName,
+ "\": ", 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) {
+ buffer = ckalloc(strlen(sym1)+2);
+ buffer[0] = '_';
+ strcpy(buffer+1, sym1);
+ *proc1Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, buffer);
+ ckfree(buffer);
+ }
+
+ *proc2Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, sym2);
+ if (*proc2Ptr == NULL) {
+ buffer = ckalloc(strlen(sym2)+2);
+ buffer[0] = '_';
+ strcpy(buffer+1, sym2);
+ *proc2Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, buffer);
+ ckfree(buffer);
+ }
+
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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
new file mode 100644
index 0000000..98c528d
--- /dev/null
+++ b/win/tclWinMtherr.c
@@ -0,0 +1,61 @@
+/*
+ * 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.
+ *
+ * SCCS: @(#) tclWinMtherr.c 1.2 96/02/15 11:54:05
+ */
+
+#include "tclInt.h"
+#include "tclPort.h"
+#include <math.h>
+
+/*
+ * The following variable is secretly shared with Tcl so we can
+ * tell if expression evaluation is in progress. If not, matherr
+ * just emulates the default behavior, which includes printing
+ * a message.
+ */
+
+extern int tcl_MathInProgress;
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * _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 (!tcl_MathInProgress) {
+ 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
new file mode 100644
index 0000000..8df95e3
--- /dev/null
+++ b/win/tclWinNotify.c
@@ -0,0 +1,325 @@
+/*
+ * 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.
+ *
+ * SCCS: @(#) tclWinNotify.c 1.17 97/05/23 10:48:44
+ */
+
+#include "tclInt.h"
+#include "tclPort.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. */
+
+/*
+ * The following static structure contains the state information for the
+ * Windows implementation of the Tcl notifier.
+ */
+
+static struct {
+ HWND hwnd; /* Messaging window. */
+ int timeout; /* Current timeout value. */
+ int timerActive; /* 1 if interval timer is running. */
+} notifier;
+
+/*
+ * Static routines defined in this file.
+ */
+
+static void InitNotifier(void);
+static void NotifierExitHandler(ClientData clientData);
+static LRESULT CALLBACK NotifierProc(HWND hwnd, UINT message,
+ WPARAM wParam, LPARAM lParam);
+static void UpdateTimer(int timeout);
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InitNotifier --
+ *
+ * Initializes the notifier window.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Creates a new notifier window and window class.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+InitNotifier(void)
+{
+ WNDCLASS class;
+
+ initialized = 1;
+ notifier.timerActive = 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 (!RegisterClass(&class)) {
+ panic("Unable to register TclNotifier window class");
+ }
+ notifier.hwnd = CreateWindow("TclNotifier", "TclNotifier", WS_TILED,
+ 0, 0, 0, 0, NULL, NULL, TclWinGetTclInstance(), NULL);
+ Tcl_CreateExitHandler(NotifierExitHandler, NULL);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * NotifierExitHandler --
+ *
+ * This function is called to cleanup the notifier state before
+ * Tcl is unloaded.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Destroys the notifier window.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+NotifierExitHandler(
+ ClientData clientData) /* Old window proc */
+{
+ initialized = 0;
+ if (notifier.hwnd) {
+ KillTimer(notifier.hwnd, INTERVAL_TIMER);
+ DestroyWindow(notifier.hwnd);
+ UnregisterClass("TclNotifier", TclWinGetTclInstance());
+ notifier.hwnd = NULL;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * UpdateTimer --
+ *
+ * This function starts or stops the notifier interval timer.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+UpdateTimer(
+ int timeout) /* ms timeout, 0 means cancel timer */
+{
+ notifier.timeout = timeout;
+ if (timeout != 0) {
+ notifier.timerActive = 1;
+ SetTimer(notifier.hwnd, INTERVAL_TIMER,
+ (unsigned long) notifier.timeout, NULL);
+ } else {
+ notifier.timerActive = 0;
+ KillTimer(notifier.hwnd, INTERVAL_TIMER);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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. */
+{
+ UINT timeout;
+
+ if (!initialized) {
+ InitNotifier();
+ }
+
+ 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;
+ }
+ }
+ UpdateTimer(timeout);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * NotifierProc --
+ *
+ * This procedure is invoked by Windows to process the timer
+ * message whenever we are using an external dispatch loop.
+ *
+ * Results:
+ * A standard windows result.
+ *
+ * Side effects:
+ * Services any pending events.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static LRESULT CALLBACK
+NotifierProc(
+ HWND hwnd,
+ UINT message,
+ WPARAM wParam,
+ LPARAM lParam)
+{
+
+ 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. */
+{
+ MSG msg;
+ int timeout;
+
+ if (!initialized) {
+ InitNotifier();
+ }
+
+ /*
+ * Only use the interval timer for non-zero timeouts. This avoids
+ * generating useless messages when we really just want to poll.
+ */
+
+ if (timePtr) {
+ timeout = timePtr->sec * 1000 + timePtr->usec / 1000;
+ } else {
+ timeout = 0;
+ }
+ UpdateTimer(timeout);
+
+ if (!timePtr || (timeout != 0)
+ || PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE)) {
+ if (!GetMessage(&msg, NULL, 0, 0)) {
+
+ /*
+ * The application is exiting, so repost the quit message
+ * and start unwinding.
+ */
+
+ PostQuitMessage(msg.wParam);
+ return -1;
+ }
+
+ /*
+ * Handle timer expiration as a special case so we don't
+ * claim to be doing work when we aren't.
+ */
+
+ if (msg.message == WM_TIMER && msg.hwnd == notifier.hwnd) {
+ return 0;
+ }
+
+ TranslateMessage(&msg);
+ DispatchMessage(&msg);
+ return 1;
+ }
+ return 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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
new file mode 100644
index 0000000..a7aeaf4
--- /dev/null
+++ b/win/tclWinPipe.c
@@ -0,0 +1,2470 @@
+/*
+ * 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.
+ *
+ * SCCS: @(#) tclWinPipe.c 1.49 97/11/06 17:33:03
+ */
+
+#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 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.
+ */
+
+#define WIN32S_PIPE 1 /* Win32s emulated pipe. */
+#define WIN32S_TMPFILE 2 /* Win32s emulated temporary file. */
+#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;
+
+/*
+ * The following structure is used to keep track of temporary files under
+ * Win32s and delete the disk file when the open handle is closed.
+ * The type field will be WIN32S_TMPFILE.
+ */
+
+typedef struct TmpFile {
+ WinFile file; /* Common part. */
+ char name[MAX_PATH]; /* Name of temp file. */
+} TmpFile;
+
+/*
+ * The following structure represents a synchronous pipe under Win32s.
+ * The type field will be WIN32S_PIPE. The handle field will refer to
+ * an open file when Tcl is reading from the "pipe", otherwise it is
+ * INVALID_HANDLE_VALUE.
+ */
+
+typedef struct WinPipe {
+ WinFile file; /* Common part. */
+ struct WinPipe *otherPtr; /* Pointer to the WinPipe structure that
+ * corresponds to the other end of this
+ * pipe. */
+ char *fileName; /* The name of the staging file that gets
+ * the data written to this pipe. Malloc'd.
+ * and shared by both ends of the pipe. Only
+ * when both ends are freed will fileName be
+ * freed and the file it refers to deleted. */
+} WinPipe;
+
+/*
+ * 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;
+
+/*
+ * State flags used in the PipeInfo structure below.
+ */
+
+#define PIPE_PENDING (1<<0) /* Message is pending in the queue. */
+#define PIPE_ASYNC (1<<1) /* Channel is non-blocking. */
+
+/*
+ * This structure describes per-instance data for a pipe based channel.
+ */
+
+typedef struct PipeInfo {
+ 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. */
+ struct PipeInfo *nextPtr; /* Pointer to next registered pipe. */
+} PipeInfo;
+
+/*
+ * The following pointer refers to the head of the list of pipes
+ * that are being watched for file events.
+ */
+
+static PipeInfo *firstPipePtr;
+
+/*
+ * 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(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 PipeBlockModeProc(ClientData instanceData, int mode);
+static void PipeCheckProc _ANSI_ARGS_((ClientData clientData,
+ int flags));
+static int PipeCloseProc(ClientData instanceData, Tcl_Interp *interp);
+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 void PipeWatchProc(ClientData instanceData, int mask);
+static void PipeSetupProc _ANSI_ARGS_((ClientData clientData,
+ int flags));
+static int TempFileName(char name[MAX_PATH]);
+
+/*
+ * This structure describes the channel type structure for command pipe
+ * based IO.
+ */
+
+static Tcl_ChannelType pipeChannelType = {
+ "pipe", /* Type name. */
+ PipeBlockModeProc, /* Set blocking or non-blocking mode.*/
+ PipeCloseProc, /* 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. */
+};
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * PipeInit --
+ *
+ * This function initializes the static variables for this file.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Creates a new event source.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+PipeInit()
+{
+ initialized = 1;
+ firstPipePtr = NULL;
+ procList = NULL;
+ Tcl_CreateEventSource(PipeSetupProc, PipeCheckProc, NULL);
+ Tcl_CreateExitHandler(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 clientData; /* Old window proc */
+{
+ Tcl_DeleteEventSource(PipeSetupProc, PipeCheckProc, NULL);
+ initialized = 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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(data, flags)
+ ClientData data; /* Not used. */
+ int flags; /* Event flags as passed to Tcl_DoOneEvent. */
+{
+ PipeInfo *infoPtr;
+ Tcl_Time blockTime = { 0, 0 };
+
+ if (!(flags & TCL_FILE_EVENTS)) {
+ return;
+ }
+
+ /*
+ * Check to see if there is a watched pipe. If so, poll.
+ */
+
+ for (infoPtr = firstPipePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
+ if (infoPtr->watchMask) {
+ Tcl_SetMaxBlockTime(&blockTime);
+ break;
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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(data, flags)
+ ClientData data; /* Not used. */
+ int flags; /* Event flags as passed to Tcl_DoOneEvent. */
+{
+ PipeInfo *infoPtr;
+ PipeEvent *evPtr;
+
+ if (!(flags & TCL_FILE_EVENTS)) {
+ return;
+ }
+
+ /*
+ * Queue events for any watched pipes that don't already have events
+ * queued.
+ */
+
+ for (infoPtr = firstPipePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
+ if (infoPtr->watchMask && !(infoPtr->flags & PIPE_PENDING)) {
+ infoPtr->flags |= PIPE_PENDING;
+ evPtr = (PipeEvent *) ckalloc(sizeof(PipeEvent));
+ evPtr->header.proc = PipeEventProc;
+ evPtr->infoPtr = infoPtr;
+ Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * MakeFile --
+ *
+ * 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.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static TclFile
+MakeFile(handle)
+ HANDLE handle; /* Type-specific data. */
+{
+ WinFile *filePtr;
+
+ filePtr = (WinFile *) ckalloc(sizeof(WinFile));
+ filePtr->type = WIN_FILE;
+ filePtr->handle = handle;
+
+ return (TclFile)filePtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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 MakeFile(handle);
+ } else {
+ return (TclFile) NULL;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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)
+ char name[MAX_PATH]; /* Buffer in which name for temporary
+ * file gets stored. */
+{
+ if ((GetTempPath(MAX_PATH, name) == 0) ||
+ (GetTempFileName(name, "TCL", 0, name) == 0)) {
+ name[0] = '.';
+ name[1] = '\0';
+ if (GetTempFileName(name, "TCL", 0, name) == 0) {
+ return 0;
+ }
+ }
+ return 1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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, namePtr)
+ char *contents; /* String to write into temp file, or NULL. */
+ Tcl_DString *namePtr; /* If non-NULL, pointer to initialized
+ * DString that is filled with the name of
+ * the temp file that was created. */
+{
+ char name[MAX_PATH];
+ HANDLE handle;
+
+ if (TempFileName(name) == 0) {
+ return NULL;
+ }
+
+ handle = CreateFile(name, GENERIC_READ | GENERIC_WRITE, 0, NULL,
+ CREATE_ALWAYS, FILE_ATTRIBUTE_TEMPORARY|FILE_FLAG_DELETE_ON_CLOSE,
+ NULL);
+ if (handle == INVALID_HANDLE_VALUE) {
+ goto error;
+ }
+
+ /*
+ * Write the file out, doing line translations on the way.
+ */
+
+ if (contents != NULL) {
+ DWORD result, length;
+ char *p;
+
+ for (p = contents; *p != '\0'; p++) {
+ if (*p == '\n') {
+ length = p - contents;
+ if (length > 0) {
+ if (!WriteFile(handle, contents, length, &result, NULL)) {
+ goto error;
+ }
+ }
+ if (!WriteFile(handle, "\r\n", 2, &result, NULL)) {
+ goto error;
+ }
+ contents = p+1;
+ }
+ }
+ length = p - contents;
+ if (length > 0) {
+ if (!WriteFile(handle, contents, length, &result, NULL)) {
+ goto error;
+ }
+ }
+ }
+
+ if (SetFilePointer(handle, 0, NULL, FILE_BEGIN) == 0xFFFFFFFF) {
+ goto error;
+ }
+
+ if (namePtr != NULL) {
+ Tcl_DStringAppend(namePtr, name, -1);
+ }
+
+ /*
+ * Under Win32s a file created with FILE_FLAG_DELETE_ON_CLOSE won't
+ * actually be deleted when it is closed, so we have to do it ourselves.
+ */
+
+ if (TclWinGetPlatformId() == VER_PLATFORM_WIN32s) {
+ TmpFile *tmpFilePtr = (TmpFile *) ckalloc(sizeof(TmpFile));
+ tmpFilePtr->file.type = WIN32S_TMPFILE;
+ tmpFilePtr->file.handle = handle;
+ strcpy(tmpFilePtr->name, name);
+ return (TclFile)tmpFilePtr;
+ } else {
+ return MakeFile(handle);
+ }
+
+ error:
+ TclWinConvertError(GetLastError());
+ CloseHandle(handle);
+ DeleteFile(name);
+ return 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)
+ char *path;
+ int mode;
+{
+ HANDLE handle;
+ DWORD accessMode, createMode, shareMode, flags;
+ SECURITY_ATTRIBUTES sec;
+
+ /*
+ * 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;
+ }
+
+ /*
+ * If the file is not being created, use the existing file attributes.
+ */
+
+ flags = 0;
+ if (!(mode & O_CREAT)) {
+ flags = GetFileAttributes(path);
+ if (flags == 0xFFFFFFFF) {
+ flags = 0;
+ }
+ }
+
+ /*
+ * Set up the security attributes so this file is not inherited by
+ * child processes.
+ */
+
+ sec.nLength = sizeof(sec);
+ sec.lpSecurityDescriptor = NULL;
+ sec.bInheritHandle = 0;
+
+ /*
+ * Set up the file sharing mode. We want to allow simultaneous access.
+ */
+
+ shareMode = FILE_SHARE_READ | FILE_SHARE_WRITE;
+
+ /*
+ * Now we get to create the file.
+ */
+
+ handle = CreateFile(path, accessMode, shareMode, &sec, createMode, flags,
+ (HANDLE) NULL);
+ if (handle == INVALID_HANDLE_VALUE) {
+ DWORD err = GetLastError();
+ if ((err & 0xffffL) == ERROR_OPEN_FAILED) {
+ err = (mode & O_CREAT) ? ERROR_FILE_EXISTS : ERROR_FILE_NOT_FOUND;
+ }
+ TclWinConvertError(err);
+ return NULL;
+ }
+
+ /*
+ * Seek to the end of file if we are writing.
+ */
+
+ if (mode & O_WRONLY) {
+ SetFilePointer(handle, 0, NULL, FILE_END);
+ }
+
+ return MakeFile(handle);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpCreatePipe --
+ *
+ * Creates an anonymous pipe. Under Win32s, creates a temp file
+ * that is used to simulate a pipe.
+ *
+ * Results:
+ * Returns 1 on success, 0 on failure.
+ *
+ * Side effects:
+ * Creates a pipe.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclpCreatePipe(readPipe, writePipe)
+ 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 = MakeFile(readHandle);
+ *writePipe = MakeFile(writeHandle);
+ return 1;
+ }
+
+ if (TclWinGetPlatformId() == VER_PLATFORM_WIN32s) {
+ WinPipe *readPipePtr, *writePipePtr;
+ char buf[MAX_PATH];
+
+ if (TempFileName(buf) != 0) {
+ readPipePtr = (WinPipe *) ckalloc(sizeof(WinPipe));
+ writePipePtr = (WinPipe *) ckalloc(sizeof(WinPipe));
+
+ readPipePtr->file.type = WIN32S_PIPE;
+ readPipePtr->otherPtr = writePipePtr;
+ readPipePtr->fileName = strcpy(ckalloc(strlen(buf) + 1), buf);
+ readPipePtr->file.handle = INVALID_HANDLE_VALUE;
+ writePipePtr->file.type = WIN32S_PIPE;
+ writePipePtr->otherPtr = readPipePtr;
+ writePipePtr->fileName = readPipePtr->fileName;
+ writePipePtr->file.handle = INVALID_HANDLE_VALUE;
+
+ *readPipe = (TclFile)readPipePtr;
+ *writePipe = (TclFile)writePipePtr;
+
+ 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(file)
+ TclFile file; /* The file to close. */
+{
+ WinFile *filePtr = (WinFile *) file;
+ WinPipe *pipePtr;
+
+ switch (filePtr->type) {
+ case WIN_FILE:
+ case WIN32S_TMPFILE:
+ if (CloseHandle(filePtr->handle) == FALSE) {
+ TclWinConvertError(GetLastError());
+ ckfree((char *) filePtr);
+ return -1;
+ }
+ /*
+ * Simulate deleting the file on close for Win32s.
+ */
+
+ if (filePtr->type == WIN32S_TMPFILE) {
+ DeleteFile(((TmpFile*)filePtr)->name);
+ }
+ break;
+
+ case WIN32S_PIPE:
+ pipePtr = (WinPipe *) file;
+
+ if (pipePtr->otherPtr != NULL) {
+ pipePtr->otherPtr->otherPtr = NULL;
+ } else {
+ if (pipePtr->file.handle != INVALID_HANDLE_VALUE) {
+ CloseHandle(pipePtr->file.handle);
+ }
+ DeleteFile(pipePtr->fileName);
+ ckfree((char *) pipePtr->fileName);
+ }
+ break;
+
+ default:
+ panic("Tcl_CloseFile: 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(pid)
+ Tcl_Pid pid; /* The HANDLE of the child process. */
+{
+ ProcInfo *infoPtr;
+
+ for (infoPtr = procList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
+ if (infoPtr->hProcess == (HANDLE) pid) {
+ return infoPtr->dwProcessId;
+ }
+ }
+ 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
+ * synchronously under Win32s and asynchronously under Windows NT
+ * and Windows 95, 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
+ * interp->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(interp, argc, argv, inputFile, outputFile, errorFile,
+ pidPtr)
+ 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;
+ STARTUPINFO startInfo;
+ PROCESS_INFORMATION procInfo;
+ SECURITY_ATTRIBUTES secAtts;
+ HANDLE hProcess, h, inputHandle, outputHandle, errorHandle;
+ char execPath[MAX_PATH];
+ char *originalName;
+ WinFile *filePtr;
+
+ if (!initialized) {
+ PipeInit();
+ }
+
+ applType = ApplicationType(interp, argv[0], execPath);
+ if (applType == APPL_NONE) {
+ return TCL_ERROR;
+ }
+ originalName = argv[0];
+ argv[0] = execPath;
+
+ result = TCL_ERROR;
+ Tcl_DStringInit(&cmdLine);
+
+ if (TclWinGetPlatformId() == VER_PLATFORM_WIN32s) {
+ /*
+ * Under Win32s, there are no pipes. In order to simulate pipe
+ * behavior, the child processes are run synchronously and their
+ * I/O is redirected from/to temporary files before the next
+ * stage of the pipeline is started.
+ */
+
+ MSG msg;
+ DWORD status;
+ DWORD args[4];
+ void *trans[5];
+ char *inputFileName, *outputFileName;
+ Tcl_DString inputTempFile, outputTempFile;
+
+ BuildCommandLine(argc, argv, &cmdLine);
+
+ ZeroMemory(&startInfo, sizeof(startInfo));
+ startInfo.cb = sizeof(startInfo);
+
+ Tcl_DStringInit(&inputTempFile);
+ Tcl_DStringInit(&outputTempFile);
+ outputHandle = INVALID_HANDLE_VALUE;
+
+ inputFileName = NULL;
+ outputFileName = NULL;
+ if (inputFile != NULL) {
+ filePtr = (WinFile *) inputFile;
+ switch (filePtr->type) {
+ case WIN_FILE:
+ case WIN32S_TMPFILE: {
+ h = INVALID_HANDLE_VALUE;
+ inputFileName = MakeTempFile(&inputTempFile);
+ if (inputFileName != NULL) {
+ h = CreateFile(inputFileName, GENERIC_WRITE, 0,
+ NULL, CREATE_ALWAYS, 0, NULL);
+ }
+ if (h == INVALID_HANDLE_VALUE) {
+ Tcl_AppendResult(interp, "couldn't duplicate input handle: ",
+ Tcl_PosixError(interp), (char *) NULL);
+ goto end32s;
+ }
+ CopyChannel(h, filePtr->handle);
+ CloseHandle(h);
+ break;
+ }
+ case WIN32S_PIPE: {
+ inputFileName = ((WinPipe*)inputFile)->fileName;
+ break;
+ }
+ }
+ }
+ if (inputFileName == NULL) {
+ inputFileName = "nul";
+ }
+ if (outputFile != NULL) {
+ filePtr = (WinFile *)outputFile;
+ if (filePtr->type == WIN_FILE) {
+ outputFileName = MakeTempFile(&outputTempFile);
+ if (outputFileName == NULL) {
+ Tcl_AppendResult(interp, "couldn't duplicate output handle: ",
+ Tcl_PosixError(interp), (char *) NULL);
+ goto end32s;
+ }
+ outputHandle = filePtr->handle;
+ } else if (filePtr->type == WIN32S_PIPE) {
+ outputFileName = ((WinPipe*)outputFile)->fileName;
+ }
+ }
+ if (outputFileName == NULL) {
+ outputFileName = "nul";
+ }
+
+ if (applType == APPL_DOS) {
+ args[0] = (DWORD) Tcl_DStringValue(&cmdLine);
+ args[1] = (DWORD) inputFileName;
+ args[2] = (DWORD) outputFileName;
+ trans[0] = &args[0];
+ trans[1] = &args[1];
+ trans[2] = &args[2];
+ trans[3] = NULL;
+ if (TclWinSynchSpawn(args, 0, trans, pidPtr) != 0) {
+ result = TCL_OK;
+ }
+ } else if (applType == APPL_WIN3X) {
+ args[0] = (DWORD) Tcl_DStringValue(&cmdLine);
+ trans[0] = &args[0];
+ trans[1] = NULL;
+ if (TclWinSynchSpawn(args, 1, trans, pidPtr) != 0) {
+ result = TCL_OK;
+ }
+ } else {
+ if (CreateProcess(NULL, Tcl_DStringValue(&cmdLine), NULL, NULL,
+ FALSE, DETACHED_PROCESS, NULL, NULL, &startInfo,
+ &procInfo) != 0) {
+ CloseHandle(procInfo.hThread);
+ while (1) {
+ if (GetExitCodeProcess(procInfo.hProcess, &status) == FALSE) {
+ break;
+ }
+ if (status != STILL_ACTIVE) {
+ break;
+ }
+ if (PeekMessage(&msg, NULL, 0, 0, PM_REMOVE) == TRUE) {
+ TranslateMessage(&msg);
+ DispatchMessage(&msg);
+ }
+ }
+ *pidPtr = (Tcl_Pid) procInfo.hProcess;
+ if (*pidPtr != 0) {
+ ProcInfo *procPtr = (ProcInfo *) ckalloc(sizeof(ProcInfo));
+ procPtr->hProcess = procInfo.hProcess;
+ procPtr->dwProcessId = procInfo.dwProcessId;
+ procPtr->nextPtr = procList;
+ procList = procPtr;
+ }
+ result = TCL_OK;
+ }
+ }
+ if (result != TCL_OK) {
+ TclWinConvertError(GetLastError());
+ Tcl_AppendResult(interp, "couldn't execute \"", originalName,
+ "\": ", Tcl_PosixError(interp), (char *) NULL);
+ }
+
+ end32s:
+ if (outputHandle != INVALID_HANDLE_VALUE) {
+ /*
+ * Now copy stuff from temp file to actual output handle. Don't
+ * close outputHandle because it is associated with the output
+ * file owned by the caller.
+ */
+
+ h = CreateFile(outputFileName, GENERIC_READ, 0, NULL, OPEN_ALWAYS,
+ 0, NULL);
+ if (h != INVALID_HANDLE_VALUE) {
+ CopyChannel(outputHandle, h);
+ }
+ CloseHandle(h);
+ }
+
+ if (inputFileName == Tcl_DStringValue(&inputTempFile)) {
+ DeleteFile(inputFileName);
+ }
+
+ if (outputFileName == Tcl_DStringValue(&outputTempFile)) {
+ DeleteFile(outputFileName);
+ }
+
+ Tcl_DStringFree(&inputTempFile);
+ Tcl_DStringFree(&outputTempFile);
+ Tcl_DStringFree(&cmdLine);
+ return result;
+ }
+ 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 = CreateFile("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 = CreateFile("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(argc, argv, &cmdLine);
+
+ if (!CreateProcess(NULL, Tcl_DStringValue(&cmdLine), NULL, NULL, TRUE,
+ createFlags, NULL, NULL, &startInfo, &procInfo)) {
+ TclWinConvertError(GetLastError());
+ Tcl_AppendResult(interp, "couldn't execute \"", originalName,
+ "\": ", Tcl_PosixError(interp), (char *) NULL);
+ goto end;
+ }
+
+ if (applType == APPL_DOS) {
+ WaitForSingleObject(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) {
+ ProcInfo *procPtr = (ProcInfo *) ckalloc(sizeof(ProcInfo));
+ procPtr->hProcess = procInfo.hProcess;
+ procPtr->dwProcessId = procInfo.dwProcessId;
+ procPtr->nextPtr = procList;
+ procList = procPtr;
+ }
+ 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 = CreateFile("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, fullPath)
+ Tcl_Interp *interp; /* Interp, for error message. */
+ const char *originalName; /* Name of the application to find. */
+ char fullPath[MAX_PATH]; /* Filled with complete path to
+ * application. */
+{
+ int applType, i;
+ HANDLE hFile;
+ char *ext, *rest;
+ char buf[2];
+ DWORD read;
+ IMAGE_DOS_HEADER header;
+ 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;
+ for (i = 0; i < (int) (sizeof(extensions) / sizeof(extensions[0])); i++) {
+ lstrcpyn(fullPath, originalName, MAX_PATH - 5);
+ lstrcat(fullPath, extensions[i]);
+
+ SearchPath(NULL, fullPath, NULL, MAX_PATH, fullPath, &rest);
+
+ /*
+ * Ignore matches on directories or data files, return if identified
+ * a known type.
+ */
+
+ if (GetFileAttributes(fullPath) & FILE_ATTRIBUTE_DIRECTORY) {
+ continue;
+ }
+
+ ext = strrchr(fullPath, '.');
+ if ((ext != NULL) && (strcmpi(ext, ".bat") == 0)) {
+ applType = APPL_DOS;
+ break;
+ }
+
+ hFile = CreateFile(fullPath, 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) && (strcmpi(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;
+ }
+
+ 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.
+ */
+
+ GetShortPathName(fullPath, fullPath, MAX_PATH);
+ }
+ 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(argc, argv, linePtr)
+ int argc; /* Number of arguments. */
+ char **argv; /* Argument strings. */
+ Tcl_DString *linePtr; /* Initialized Tcl_DString that receives the
+ * command line. */
+{
+ char *start, *special;
+ int quote, i;
+
+ for (i = 0; i < argc; i++) {
+ if (i > 0) {
+ Tcl_DStringAppend(linePtr, " ", 1);
+ }
+
+ quote = 0;
+ for (start = argv[i]; *start != '\0'; start++) {
+ if (isspace(*start)) {
+ quote = 1;
+ Tcl_DStringAppend(linePtr, "\"", 1);
+ break;
+ }
+ }
+
+ start = argv[i];
+ for (special = argv[i]; ; ) {
+ if ((*special == '\\') &&
+ (special[1] == '\\' || special[1] == '"')) {
+ Tcl_DStringAppend(linePtr, 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(linePtr, start, special - start);
+ break;
+ }
+ if (*special != '\\') {
+ break;
+ }
+ }
+ Tcl_DStringAppend(linePtr, start, special - start);
+ start = special;
+ }
+ if (*special == '"') {
+ Tcl_DStringAppend(linePtr, start, special - start);
+ Tcl_DStringAppend(linePtr, "\\\"", 2);
+ start = special + 1;
+ }
+ if (*special == '\0') {
+ break;
+ }
+ special++;
+ }
+ Tcl_DStringAppend(linePtr, start, special - start);
+ if (quote) {
+ Tcl_DStringAppend(linePtr, "\"", 1);
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * MakeTempFile --
+ *
+ * Helper function for TclpCreateProcess under Win32s. Makes a
+ * temporary file that _won't_ go away automatically when it's file
+ * handle is closed. Used for simulated pipes, which are written
+ * in one pass and reopened and read in the next pass.
+ *
+ * Results:
+ * namePtr is filled with the name of the temporary file.
+ *
+ * Side effects:
+ * A temporary file with the name specified by namePtr is created.
+ * The caller is responsible for deleting this temporary file.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static char *
+MakeTempFile(namePtr)
+ Tcl_DString *namePtr; /* Initialized Tcl_DString that is filled
+ * with the name of the temporary file that
+ * was created. */
+{
+ char name[MAX_PATH];
+
+ if (TempFileName(name) == 0) {
+ return NULL;
+ }
+
+ Tcl_DStringAppend(namePtr, name, -1);
+ return Tcl_DStringValue(namePtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CopyChannel --
+ *
+ * Helper function used by TclpCreateProcess under Win32s. Copies
+ * what remains of source file to destination file; source file
+ * pointer need not be positioned at the beginning of the file if
+ * all of source file is not desired, but data is copied up to end
+ * of source file.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+CopyChannel(dst, src)
+ HANDLE dst; /* Destination file. */
+ HANDLE src; /* Source file. */
+{
+ char buf[8192];
+ DWORD dwRead, dwWrite;
+
+ while (ReadFile(src, buf, sizeof(buf), &dwRead, NULL) != FALSE) {
+ if (dwRead == 0) {
+ break;
+ }
+ if (WriteFile(dst, buf, dwRead, &dwWrite, NULL) == FALSE) {
+ break;
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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(readFile, writeFile, errorFile, numPids, pidPtr)
+ 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[20];
+ int channelId;
+ PipeInfo *infoPtr = (PipeInfo *) ckalloc((unsigned) sizeof(PipeInfo));
+
+ if (!initialized) {
+ PipeInit();
+ }
+
+ infoPtr->watchMask = 0;
+ infoPtr->flags = 0;
+ infoPtr->readFile = readFile;
+ infoPtr->writeFile = writeFile;
+ infoPtr->errorFile = errorFile;
+ infoPtr->numPids = numPids;
+ infoPtr->pidPtr = pidPtr;
+
+ /*
+ * Use one of the fds associated with the channel as the
+ * channel id.
+ */
+
+ if (readFile) {
+ WinPipe *pipePtr = (WinPipe *) readFile;
+ if (pipePtr->file.type == WIN32S_PIPE
+ && pipePtr->file.handle == INVALID_HANDLE_VALUE) {
+ pipePtr->file.handle = CreateFile(pipePtr->fileName, GENERIC_READ,
+ 0, NULL, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL);
+ }
+ channelId = (int) pipePtr->file.handle;
+ } else if (writeFile) {
+ channelId = (int) ((WinFile*)writeFile)->handle;
+ } else if (errorFile) {
+ channelId = (int) ((WinFile*)errorFile)->handle;
+ } else {
+ channelId = 0;
+ }
+
+ infoPtr->validMask = 0;
+ if (readFile != NULL) {
+ infoPtr->validMask |= TCL_READABLE;
+ }
+ if (writeFile != NULL) {
+ 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".
+ */
+
+ sprintf(channelName, "file%d", channelId);
+ 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
+ * interp->result.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Modifies interp->result.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclGetAndDetachPids(interp, chan)
+ Tcl_Interp *interp;
+ Tcl_Channel chan;
+{
+ PipeInfo *pipePtr;
+ Tcl_ChannelType *chanTypePtr;
+ int i;
+ char buf[20];
+
+ /*
+ * 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++) {
+ sprintf(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(instanceData, mode)
+ 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;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * PipeCloseProc --
+ *
+ * Closes a pipe based IO channel.
+ *
+ * Results:
+ * 0 on success, errno otherwise.
+ *
+ * Side effects:
+ * Closes the physical channel.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+PipeCloseProc(instanceData, interp)
+ ClientData instanceData; /* Pointer to PipeInfo structure. */
+ Tcl_Interp *interp; /* For error reporting. */
+{
+ PipeInfo *pipePtr = (PipeInfo *) instanceData;
+ Tcl_Channel errChan;
+ int errorCode, result;
+ PipeInfo *infoPtr, **nextPtrPtr;
+
+ /*
+ * Remove the file from the list of watched files.
+ */
+
+ for (nextPtrPtr = &firstPipePtr, infoPtr = *nextPtrPtr; infoPtr != NULL;
+ nextPtrPtr = &infoPtr->nextPtr, infoPtr = *nextPtrPtr) {
+ if (infoPtr == (PipeInfo *)pipePtr) {
+ *nextPtrPtr = infoPtr->nextPtr;
+ break;
+ }
+ }
+
+ errorCode = 0;
+ if (pipePtr->readFile != NULL) {
+ if (TclpCloseFile(pipePtr->readFile) != 0) {
+ errorCode = errno;
+ }
+ }
+ if (pipePtr->writeFile != NULL) {
+ if (TclpCloseFile(pipePtr->writeFile) != 0) {
+ if (errorCode == 0) {
+ errorCode = errno;
+ }
+ }
+ }
+
+ /*
+ * Wrap the error file into a channel and give it to the cleanup
+ * routine. If we are running in Win32s, just delete the error file
+ * immediately, because it was never used.
+ */
+
+ if (pipePtr->errorFile) {
+ WinFile *filePtr;
+ OSVERSIONINFO os;
+
+ os.dwOSVersionInfoSize = sizeof(os);
+ GetVersionEx(&os);
+ if (os.dwPlatformId == VER_PLATFORM_WIN32s) {
+ TclpCloseFile(pipePtr->errorFile);
+ errChan = NULL;
+ } else {
+ filePtr = (WinFile*)pipePtr->errorFile;
+ errChan = Tcl_MakeFileChannel((ClientData) filePtr->handle,
+ TCL_READABLE);
+ }
+ } else {
+ errChan = NULL;
+ }
+ result = TclCleanupChildren(interp, pipePtr->numPids, pipePtr->pidPtr,
+ errChan);
+ if (pipePtr->numPids > 0) {
+ ckfree((char *) pipePtr->pidPtr);
+ }
+ 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(instanceData, buf, bufSize, errorCode)
+ 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;
+ DWORD bytesRead;
+
+ *errorCode = 0;
+ if (filePtr->type == WIN32S_PIPE) {
+ if (((WinPipe *)filePtr)->otherPtr != NULL) {
+ panic("PipeInputProc: child process isn't finished writing");
+ }
+ if (filePtr->handle == INVALID_HANDLE_VALUE) {
+ filePtr->handle = CreateFile(((WinPipe *)filePtr)->fileName,
+ GENERIC_READ, 0, NULL, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL,
+ NULL);
+ }
+ if (filePtr->handle == INVALID_HANDLE_VALUE) {
+ goto error;
+ }
+ } else {
+ /*
+ * Pipes will block until the requested number of bytes has been
+ * read. To avoid blocking unnecessarily, we look ahead and only
+ * read as much as is available.
+ */
+
+ if (PeekNamedPipe(filePtr->handle, (LPVOID) NULL, (DWORD) 0,
+ (LPDWORD) NULL, &count, (LPDWORD) NULL) == TRUE) {
+ if ((count != 0) && ((DWORD) bufSize > count)) {
+ bufSize = (int) count;
+
+ /*
+ * This code is commented out because on Win95 we don't get
+ * notifier of eof on a pipe unless we try to read it.
+ * The correct solution is to move to threads.
+ */
+
+/* } else if ((count == 0) && (infoPtr->flags & PIPE_ASYNC)) { */
+/* errno = *errorCode = EAGAIN; */
+/* return -1; */
+ } else if ((count == 0) && !(infoPtr->flags & PIPE_ASYNC)) {
+ bufSize = 1;
+ }
+ } else {
+ goto error;
+ }
+ }
+
+ /*
+ * 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.
+ */
+
+ if (ReadFile(filePtr->handle, (LPVOID) buf, (DWORD) bufSize, &bytesRead,
+ (LPOVERLAPPED) NULL) == FALSE) {
+ goto error;
+ }
+
+ return bytesRead;
+
+ error:
+ TclWinConvertError(GetLastError());
+ if (errno == EPIPE) {
+ 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(instanceData, buf, toWrite, errorCode)
+ 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;
+
+ *errorCode = 0;
+ if (WriteFile(filePtr->handle, (LPVOID) buf, (DWORD) toWrite,
+ &bytesWritten, (LPOVERLAPPED) NULL) == FALSE) {
+ TclWinConvertError(GetLastError());
+ if (errno == EPIPE) {
+ return 0;
+ }
+ *errorCode = errno;
+ return -1;
+ }
+ return bytesWritten;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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(evPtr, flags)
+ 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;
+/* DWORD count;*/
+
+ 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 = firstPipePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
+ if (pipeEvPtr->infoPtr == infoPtr) {
+ infoPtr->flags &= ~(PIPE_PENDING);
+ break;
+ }
+ }
+
+ /*
+ * Remove stale events.
+ */
+
+ if (!infoPtr) {
+ return 1;
+ }
+
+ /*
+ * If we aren't on Win32s, 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.
+ */
+
+ filePtr = (WinFile*) ((PipeInfo*)infoPtr)->readFile;
+ if (filePtr->type != WIN32S_PIPE) {
+
+ /*
+ * On windows 95, PeekNamedPipe returns 0 on eof so we can't
+ * distinguish underflow from eof. The correct solution is to
+ * switch to the threaded implementation.
+ */
+ mask = TCL_WRITABLE|TCL_READABLE;
+/* if (PeekNamedPipe(filePtr->handle, (LPVOID) NULL, (DWORD) 0, */
+/* (LPDWORD) NULL, &count, (LPDWORD) NULL) == TRUE) { */
+/* if (count != 0) { */
+/* mask |= TCL_READABLE; */
+/* } */
+/* } else { */
+
+ /*
+ * If the pipe has been closed by the other side, then
+ * mark the pipe as readable, but not writable.
+ */
+
+/* if (GetLastError() == ERROR_BROKEN_PIPE) { */
+/* mask = TCL_READABLE; */
+/* } */
+/* } */
+ } else {
+ mask = TCL_READABLE | TCL_WRITABLE;
+ }
+
+ /*
+ * 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(instanceData, mask)
+ 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;
+
+ /*
+ * For now, we just send a message to ourselves so we can poll the
+ * channel for readable events.
+ */
+
+ infoPtr->watchMask = mask & infoPtr->validMask;
+ if (infoPtr->watchMask) {
+ Tcl_Time blockTime = { 0, 0 };
+ if (!oldMask) {
+ infoPtr->nextPtr = firstPipePtr;
+ firstPipePtr = infoPtr;
+ }
+ Tcl_SetMaxBlockTime(&blockTime);
+ } else {
+ if (oldMask) {
+ /*
+ * Remove the pipe from the list of watched pipes.
+ */
+
+ for (nextPtrPtr = &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(instanceData, direction, handlePtr)
+ 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;
+ if (filePtr->type == WIN32S_PIPE) {
+ if (filePtr->handle == INVALID_HANDLE_VALUE) {
+ filePtr->handle = CreateFile(((WinPipe *)filePtr)->fileName,
+ GENERIC_READ, 0, NULL, OPEN_ALWAYS,
+ FILE_ATTRIBUTE_NORMAL, NULL);
+ }
+ if (filePtr->handle == INVALID_HANDLE_VALUE) {
+ return TCL_ERROR;
+ }
+ }
+ *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(pid, statPtr, options)
+ Tcl_Pid pid;
+ int *statPtr;
+ int options;
+{
+ ProcInfo *infoPtr, **prevPtrPtr;
+ int flags;
+ Tcl_Pid result;
+ DWORD ret;
+
+ if (!initialized) {
+ PipeInit();
+ }
+
+ /*
+ * If no pid is specified, do nothing.
+ */
+
+ if (pid == 0) {
+ *statPtr = 0;
+ return 0;
+ }
+
+ /*
+ * Find the process on the process list.
+ */
+
+ prevPtrPtr = &procList;
+ for (infoPtr = procList; infoPtr != NULL;
+ prevPtrPtr = &infoPtr->nextPtr, infoPtr = infoPtr->nextPtr) {
+ if (infoPtr->hProcess == (HANDLE) pid) {
+ break;
+ }
+ }
+
+ /*
+ * 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;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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(dummy, interp, objc, objv)
+ 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[20];
+
+ if (objc > 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?channelId?");
+ return TCL_ERROR;
+ }
+ if (objc == 1) {
+ resultPtr = Tcl_GetObjResult(interp);
+ sprintf(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++) {
+ sprintf(buf, "%lu", TclpGetPid(pipePtr->pidPtr[i]));
+ Tcl_ListObjAppendElement(/*interp*/ NULL, resultPtr,
+ Tcl_NewStringObj(buf, -1));
+ }
+ }
+ return TCL_OK;
+}
diff --git a/win/tclWinPort.h b/win/tclWinPort.h
new file mode 100644
index 0000000..99183cd
--- /dev/null
+++ b/win/tclWinPort.h
@@ -0,0 +1,399 @@
+/*
+ * 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-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.
+ *
+ * SCCS: @(#) tclWinPort.h 1.53 97/07/30 14:12:17
+ */
+
+#ifndef _TCLWINPORT
+#define _TCLWINPORT
+
+#include <malloc.h>
+#include <stdio.h>
+
+#include <stdlib.h>
+#include <string.h>
+#include <errno.h>
+#include <process.h>
+#include <signal.h>
+#include <winsock.h>
+#include <sys/stat.h>
+#include <sys/timeb.h>
+#include <time.h>
+#include <io.h>
+#include <fcntl.h>
+#include <float.h>
+
+#define WIN32_LEAN_AND_MEAN
+#include <windows.h>
+#undef WIN32_LEAN_AND_MEAN
+
+/*
+ * 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 wrap the system memory allocation routines for
+ * use by tclAlloc.c.
+ */
+
+#define TclpSysAlloc(size, isBin) ((void*)GlobalAlloc(GMEM_FIXED, \
+ (DWORD)size))
+#define TclpSysFree(ptr) (GlobalFree((HGLOBAL)ptr))
+#define TclpSysRealloc(ptr, size) ((void*)GlobalReAlloc((HGLOBAL)ptr, \
+ (DWORD)size, 0))
+
+/*
+ * 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"
+
+/*
+ * 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 MAXPATHLEN in terms of MAXPATH if available
+ */
+
+#ifndef MAXPATH
+#define MAXPATH MAX_PATH
+#endif /* MAXPATH */
+
+#ifndef MAXPATHLEN
+#define MAXPATHLEN MAXPATH
+#endif /* MAXPATHLEN */
+
+#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 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
+
+/*
+ * Provide a stub definition for TclGetUserHome().
+ */
+
+#define TclGetUserHome(name,bufferPtr) (NULL)
+
+/*
+ * 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().
+ */
+
+#ifdef _MSC_VER
+# define environ _environ
+# define hypot _hypot
+# define exception _exception
+# undef EDEADLOCK
+#endif /* _MSC_VER */
+
+/*
+ * 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
+
+/*
+ * 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 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 implements the Windows method for exiting the process.
+ */
+#define TclPlatformExit(status) exit(status)
+
+
+/*
+ * The following declarations belong in tclInt.h, but depend on platform
+ * specific types (e.g. struct tm).
+ */
+
+EXTERN struct tm * TclpGetDate _ANSI_ARGS_((const time_t *tp,
+ int useGMT));
+EXTERN unsigned long TclpGetPid _ANSI_ARGS_((Tcl_Pid pid));
+EXTERN size_t TclStrftime _ANSI_ARGS_((char *s, size_t maxsize,
+ const char *format, const struct tm *t));
+
+/*
+ * The following prototypes and defines replace the Windows versions
+ * of POSIX function that various compilier vendors didn't implement
+ * well or consistantly.
+ */
+
+#define stat(path, buf) TclWinStat(path, buf)
+#define lstat stat
+#define access(path, mode) TclWinAccess(path, mode)
+
+EXTERN int TclWinStat _ANSI_ARGS_((CONST char *path,
+ struct stat *buf));
+EXTERN int TclWinAccess _ANSI_ARGS_((CONST char *path,
+ int mode));
+
+#define TclpReleaseFile(file) ckfree((char *) file)
+
+/*
+ * Declarations for Windows specific functions.
+ */
+
+EXTERN void TclWinConvertError _ANSI_ARGS_((DWORD errCode));
+EXTERN void TclWinConvertWSAError _ANSI_ARGS_((DWORD errCode));
+EXTERN struct servent * PASCAL FAR
+ TclWinGetServByName _ANSI_ARGS_((const char FAR *nm,
+ const char FAR *proto));
+EXTERN int PASCAL FAR TclWinGetSockOpt _ANSI_ARGS_((SOCKET s, int level,
+ int optname, char FAR * optval, int FAR *optlen));
+EXTERN HINSTANCE TclWinGetTclInstance _ANSI_ARGS_((void));
+EXTERN HINSTANCE TclWinLoadLibrary _ANSI_ARGS_((char *name));
+EXTERN u_short PASCAL FAR
+ TclWinNToHS _ANSI_ARGS_((u_short ns));
+EXTERN int PASCAL FAR TclWinSetSockOpt _ANSI_ARGS_((SOCKET s, int level,
+ int optname, const char FAR * optval, int optlen));
+#endif /* _TCLWINPORT */
diff --git a/win/tclWinReg.c b/win/tclWinReg.c
new file mode 100644
index 0000000..5e5d450
--- /dev/null
+++ b/win/tclWinReg.c
@@ -0,0 +1,1212 @@
+/*
+ * 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.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclWinReg.c 1.8 97/08/01 11:17:49
+ */
+
+#include <tcl.h>
+#include <stdlib.h>
+
+#define WIN32_LEAN_AND_MEAN
+#include <windows.h>
+#undef WIN32_LEAN_AND_MEAN
+
+/*
+ * VC++ has an alternate entry point called DllMain, so we need to rename
+ * our entry point.
+ */
+
+#ifndef STATIC_BUILD
+#if defined(_MSC_VER)
+# define EXPORT(a,b) __declspec(dllexport) a b
+# define DllEntryPoint DllMain
+#else
+# if defined(__BORLANDC__)
+# define EXPORT(a,b) a _export b
+# else
+# define EXPORT(a,b) a b
+# endif
+#endif
+#endif
+
+/*
+ * The following macros convert between different endian ints.
+ */
+
+#define SWAPWORD(x) MAKEWORD(HIBYTE(x), LOBYTE(x))
+#define SWAPLONG(x) MAKELONG(SWAPWORD(HIWORD(x)), SWAPWORD(LOWORD(x)))
+
+/*
+ * The following flag is used in OpenKeys to indicate that the specified
+ * key should be created if it doesn't currently exist.
+ */
+
+#define REG_CREATE 1
+
+/*
+ * The following tables contain the mapping from registry root names
+ * to the system predefined keys.
+ */
+
+static char *rootKeyNames[] = {
+ "HKEY_LOCAL_MACHINE", "HKEY_USERS", "HKEY_CLASSES_ROOT",
+ "HKEY_CURRENT_USER", "HKEY_CURRENT_CONFIG", 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_REQUIREMENTS_LIST;
+
+
+/*
+ * 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, LPTSTR 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 EXPORT(int,Registry_Init)(Tcl_Interp *interp);
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DllEntryPoint --
+ *
+ * This wrapper function is used by Windows to invoke the
+ * initialization code for the DLL. If we are compiling
+ * with Visual C++, this routine will be renamed to DllMain.
+ * routine.
+ *
+ * Results:
+ * Returns TRUE;
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#ifdef __WIN32__
+#ifndef STATIC_BUILD
+BOOL APIENTRY
+DllEntryPoint(
+ HINSTANCE hInst, /* Library instance handle. */
+ DWORD reason, /* Reason this function is being called. */
+ LPVOID reserved) /* Not used. */
+{
+ return TRUE;
+}
+#endif
+#endif
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Registry_Init --
+ *
+ * This procedure initializes the registry command.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+EXPORT(int,Registry_Init)(
+ Tcl_Interp *interp)
+{
+ 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;
+
+ /*
+ * 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.
+ */
+
+ result = RecursiveDeleteKey(subkey, tail);
+
+ 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;
+
+ /*
+ * 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);
+ result = RegDeleteValue(key, valueName);
+ if (result != ERROR_SUCCESS) {
+ Tcl_AppendStringsToObj(resultPtr, "unable to delete value \"",
+ Tcl_GetStringFromObj(valueNameObj, NULL), "\" from key \"",
+ Tcl_GetStringFromObj(keyNameObj, NULL), "\": ", 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;
+ Tcl_Obj *resultPtr;
+ int result = TCL_OK;
+
+ /*
+ * 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_GetStringFromObj(patternObj, NULL);
+ } 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; RegEnumKey(key, index, buffer, MAX_PATH+1)
+ == ERROR_SUCCESS; index++) {
+ if (pattern && !Tcl_StringMatch(buffer, pattern)) {
+ continue;
+ }
+ result = Tcl_ListObjAppendElement(interp, resultPtr,
+ Tcl_NewStringObj(buffer, -1));
+ 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;
+
+ /*
+ * 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);
+
+ result = RegQueryValueEx(key, Tcl_GetStringFromObj(valueNameObj, NULL),
+ NULL, &type, NULL, NULL);
+ RegCloseKey(key);
+
+ if (result != ERROR_SUCCESS) {
+ Tcl_AppendStringsToObj(resultPtr, "unable to get type of value \"",
+ Tcl_GetStringFromObj(valueNameObj, NULL), "\" from key \"",
+ Tcl_GetStringFromObj(keyNameObj, NULL), "\": ", 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) {
+ 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;
+
+ /*
+ * Attempt to open the key for reading.
+ */
+
+ if (OpenKey(interp, keyNameObj, KEY_QUERY_VALUE, 0, &key)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Get the value once to determine the length then again to store
+ * the data in the buffer.
+ */
+
+ Tcl_DStringInit(&data);
+ resultPtr = Tcl_GetObjResult(interp);
+
+ valueName = Tcl_GetStringFromObj(valueNameObj, (int*) &length);
+ result = RegQueryValueEx(key, valueName, NULL, &type, NULL, &length);
+ if (result == ERROR_SUCCESS) {
+ Tcl_DStringSetLength(&data, length);
+ result = RegQueryValueEx(key, valueName, NULL, &type,
+ (LPBYTE) Tcl_DStringValue(&data), &length);
+ }
+ RegCloseKey(key);
+ if (result != ERROR_SUCCESS) {
+ Tcl_AppendStringsToObj(resultPtr, "unable to get value \"",
+ Tcl_GetStringFromObj(valueNameObj, NULL), "\" from key \"",
+ Tcl_GetStringFromObj(keyNameObj, NULL), "\": ", 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 *lastChar = Tcl_DStringValue(&data) + Tcl_DStringLength(&data);
+
+ /*
+ * 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 < lastChar && *p != '\0') {
+ Tcl_ListObjAppendElement(interp, resultPtr,
+ Tcl_NewStringObj(p, -1));
+ while (*p++ != '\0') {}
+ }
+ } else if ((type == REG_SZ) || (type == REG_EXPAND_SZ)) {
+ Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&data), -1);
+ } else {
+ Tcl_SetStringObj(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, result;
+ Tcl_DString buffer;
+ char *pattern;
+
+ /*
+ * 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 = RegQueryInfoKey(key, NULL, NULL, NULL, NULL, NULL, NULL, &index,
+ &size, NULL, NULL, NULL);
+ if (result != ERROR_SUCCESS) {
+ Tcl_AppendStringsToObj(resultPtr, "unable to query key \"",
+ Tcl_GetStringFromObj(keyNameObj, NULL), "\": ", NULL);
+ AppendSystemError(interp, result);
+ RegCloseKey(key);
+ result = TCL_ERROR;
+ goto done;
+ }
+ size++;
+
+
+ Tcl_DStringInit(&buffer);
+ Tcl_DStringSetLength(&buffer, size);
+ index = 0;
+ result = TCL_OK;
+
+ if (patternObj) {
+ pattern = Tcl_GetStringFromObj(patternObj, NULL);
+ } 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.
+ */
+
+ while (RegEnumValue(key, index, Tcl_DStringValue(&buffer), &size, NULL,
+ NULL, NULL, NULL) == ERROR_SUCCESS) {
+ if (!pattern || Tcl_StringMatch(Tcl_DStringValue(&buffer), pattern)) {
+ result = Tcl_ListObjAppendElement(interp, resultPtr,
+ Tcl_NewStringObj(Tcl_DStringValue(&buffer), size));
+ if (result != TCL_OK) {
+ break;
+ }
+ }
+ index++;
+ size = Tcl_DStringLength(&buffer);
+ }
+ 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;
+
+ /*
+ * Attempt to open the root key on a remote host if necessary.
+ */
+
+ if (hostName) {
+ result = RegConnectRegistry(hostName, rootKey, &rootKey);
+ 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.
+ */
+
+ if (flags & REG_CREATE) {
+ DWORD create;
+ result = RegCreateKeyEx(rootKey, keyName, 0, "",
+ REG_OPTION_NON_VOLATILE, mode, NULL, keyPtr, &create);
+ } else {
+ result = RegOpenKeyEx(rootKey, keyName, 0, mode, keyPtr);
+ }
+
+ /*
+ * 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. */
+{
+ DWORD result, subKeyLength;
+ Tcl_DString subkey;
+ HKEY hKey;
+
+ /*
+ * Do not allow NULL or empty key name.
+ */
+
+ if (!keyName || lstrlen(keyName) == '\0') {
+ return ERROR_BADKEY;
+ }
+
+ result = RegOpenKeyEx(startKey, keyName, 0,
+ KEY_ENUMERATE_SUB_KEYS | DELETE | KEY_QUERY_VALUE, &hKey);
+ if (result != ERROR_SUCCESS) {
+ return result;
+ }
+ result = RegQueryInfoKey(hKey, NULL, NULL, NULL, NULL, &subKeyLength,
+ NULL, NULL, NULL, NULL, NULL, NULL);
+ subKeyLength++;
+ if (result != ERROR_SUCCESS) {
+ return result;
+ }
+
+ Tcl_DStringInit(&subkey);
+ Tcl_DStringSetLength(&subkey, subKeyLength);
+
+ while (result == ERROR_SUCCESS) {
+ /*
+ * Always get index 0 because key deletion changes ordering.
+ */
+
+ subKeyLength = Tcl_DStringLength(&subkey);
+ result=RegEnumKeyEx(hKey, 0, Tcl_DStringValue(&subkey), &subKeyLength,
+ NULL, NULL, NULL, NULL);
+ if (result == ERROR_NO_MORE_ITEMS) {
+ result = RegDeleteKey(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;
+
+ 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);
+ 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);
+ return TCL_ERROR;
+ }
+
+ value = ConvertDWORD(type, value);
+ result = RegSetValueEx(key, valueName, 0, type, (BYTE*) &value,
+ sizeof(DWORD));
+ } else if (type == REG_MULTI_SZ) {
+ Tcl_DString data;
+ int objc, i;
+ Tcl_Obj **objv;
+ char *element;
+
+ if (Tcl_ListObjGetElements(interp, dataObj, &objc, &objv) != TCL_OK) {
+ RegCloseKey(key);
+ 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++) {
+ element = Tcl_GetStringFromObj(objv[i], NULL);
+ Tcl_DStringAppend(&data, element, -1);
+ Tcl_DStringSetLength(&data, Tcl_DStringLength(&data)+1);
+ }
+ result = RegSetValueEx(key, valueName, 0, type,
+ (LPBYTE) Tcl_DStringValue(&data),
+ (DWORD) (Tcl_DStringLength(&data)+1));
+ Tcl_DStringFree(&data);
+ } else {
+ char *data = Tcl_GetStringFromObj(dataObj, &length);
+
+ /*
+ * Include the null in the length if we are storing a null terminated
+ * string. Note that we also need to call strlen to find the first
+ * null so we don't pass bad data to the registry.
+ */
+
+ if (type == REG_SZ || type == REG_EXPAND_SZ) {
+ length = strlen(data) + 1;
+ }
+
+ result = RegSetValueEx(key, valueName, 0, type, (LPBYTE)data, length);
+ }
+ 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;
+ char *msgbuf, id[10];
+ Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
+
+ sprintf(id, "%d", error);
+ length = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM
+ | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error,
+ MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (LPTSTR)&msgbuf,
+ 0, NULL);
+ if (length == 0) {
+ if (error == ERROR_CALL_NOT_IMPLEMENTED) {
+ msgbuf = "function not supported under Win32s";
+ } else {
+ msgbuf = id;
+ }
+ } else {
+ /*
+ * Trim the trailing CR/LF from the system message.
+ */
+ if (msgbuf[length-1] == '\n') {
+ msgbuf[--length] = 0;
+ }
+ if (msgbuf[length-1] == '\r') {
+ msgbuf[--length] = 0;
+ }
+ }
+ Tcl_SetErrorCode(interp, "WINDOWS", id, msgbuf, (char *) NULL);
+ Tcl_AppendToObj(resultPtr, msgbuf, -1);
+
+ if (length != 0) {
+ LocalFree(msgbuf);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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/tclWinSock.c b/win/tclWinSock.c
new file mode 100644
index 0000000..bd81d2d
--- /dev/null
+++ b/win/tclWinSock.c
@@ -0,0 +1,2113 @@
+/*
+ * 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.
+ *
+ * SCCS: @(#) tclWinSock.c 1.80 97/10/09 18:24:59
+ */
+
+#include "tclInt.h"
+#include "tclPort.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. */
+
+/*
+ * 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. */
+ HWND hwnd; /* Handle to window for socket messages. */
+ 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 *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
+
+/*
+ * 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. */
+ 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 */
+
+/*
+ * Every open socket has an entry on the following list.
+ */
+
+static SocketInfo *socketList;
+
+/*
+ * 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 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));
+
+/*
+ * This structure describes the channel type structure for TCP socket
+ * based IO.
+ */
+
+static Tcl_ChannelType tcpChannelType = {
+ "tcp", /* Type name. */
+ TcpBlockProc, /* Set socket into blocking/non-blocking mode. */
+ TcpCloseProc, /* Close proc. */
+ TcpInputProc, /* Input proc. */
+ TcpOutputProc, /* Output proc. */
+ NULL, /* Seek proc. */
+ NULL, /* Set option proc. */
+ TcpGetOptionProc, /* Get option proc. */
+ TcpWatchProc, /* Initialize notifier to watch this channel. */
+ TcpGetHandleProc, /* Get an OS handle from channel. */
+};
+
+/*
+ * 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.
+ *
+ * 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()
+{
+ WSADATA wsaData;
+ OSVERSIONINFO info;
+ WNDCLASS class;
+
+ initialized = 1;
+ Tcl_CreateExitHandler(SocketExitHandler, (ClientData) NULL);
+
+ /*
+ * Find out if we're running on Win32s.
+ */
+
+ info.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
+ GetVersionEx(&info);
+
+ /*
+ * Check to see if Sockets are supported on this system. Since
+ * win32s panics if we call WSAStartup on a system that doesn't
+ * have winsock.dll, we need to look for it on the system first.
+ * If we find winsock, then load the library and initialize the
+ * stub table.
+ */
+
+ if ((info.dwPlatformId != VER_PLATFORM_WIN32s)
+ || (SearchPath(NULL, "WINSOCK", ".DLL", 0, NULL, NULL) != 0)) {
+ winSock.hInstance = LoadLibrary("wsock32.dll");
+ } else {
+ winSock.hInstance = NULL;
+ }
+
+ /*
+ * Initialize the function table.
+ */
+
+ if (winSock.hInstance == NULL) {
+ 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.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.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;
+ }
+
+ /*
+ * 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;
+ }
+
+ /*
+ * 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.
+ */
+
+ class.style = 0;
+ class.cbClsExtra = 0;
+ class.cbWndExtra = 0;
+ class.hInstance = TclWinGetTclInstance();
+ class.hbrBackground = NULL;
+ class.lpszMenuName = NULL;
+ class.lpszClassName = "TclSocket";
+ class.lpfnWndProc = SocketProc;
+ class.hIcon = NULL;
+ class.hCursor = NULL;
+
+ if (RegisterClass(&class)) {
+ winSock.hwnd = CreateWindow("TclSocket", "TclSocket", WS_TILED, 0, 0,
+ 0, 0, NULL, NULL, class.hInstance, NULL);
+ } else {
+ winSock.hwnd = NULL;
+ }
+ if (winSock.hwnd == NULL) {
+ TclWinConvertError(GetLastError());
+ (*winSock.WSACleanup)();
+ goto unloadLibrary;
+ }
+ Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL);
+ return;
+
+unloadLibrary:
+ FreeLibrary(winSock.hInstance);
+ winSock.hInstance = NULL;
+ return;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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. */
+{
+ if (winSock.hInstance) {
+ DestroyWindow(winSock.hwnd);
+ UnregisterClass("TclSocket", TclWinGetTclInstance());
+ (*winSock.WSACleanup)();
+ FreeLibrary(winSock.hInstance);
+ winSock.hInstance = NULL;
+ }
+ Tcl_DeleteEventSource(SocketSetupProc, SocketCheckProc, NULL);
+ initialized = 0;
+ hostnameInitialized = 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclHasSockets --
+ *
+ * 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
+TclHasSockets(interp)
+ Tcl_Interp *interp;
+{
+ if (!initialized) {
+ InitSockets();
+ }
+
+ if (winSock.hInstance != NULL) {
+ 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 };
+
+ if (!(flags & TCL_FILE_EVENTS)) {
+ return;
+ }
+
+ /*
+ * Check to see if there is a ready socket. If so, poll.
+ */
+
+ for (infoPtr = socketList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
+ if (infoPtr->readyEvents & infoPtr->watchEvents) {
+ Tcl_SetMaxBlockTime(&blockTime);
+ break;
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+
+ 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).
+ */
+
+ for (infoPtr = 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);
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+ u_long nBytes;
+ int status, events;
+
+ if (!(flags & TCL_FILE_EVENTS)) {
+ return 0;
+ }
+
+ /*
+ * Find the specified socket on the socket list.
+ */
+
+ for (infoPtr = socketList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
+ if (infoPtr->socket == eventPtr->socket) {
+ break;
+ }
+ }
+
+ /*
+ * 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) {
+ /*
+ * We must check to see if data is really available, since someone
+ * could have consumed the data in the meantime.
+ */
+
+ status = (*winSock.ioctlsocket)(infoPtr->socket, FIONREAD,
+ &nBytes);
+ if (status != SOCKET_ERROR && nBytes > 0) {
+ mask |= TCL_READABLE;
+ } else {
+ /*
+ * We are in a strange state, probably because someone
+ * besides Tcl is reading from this socket. Try to
+ * recover by clearing the read event.
+ */
+
+ infoPtr->readyEvents &= ~(FD_READ);
+
+ /*
+ * Re-issue WSAAsyncSelect() since we are gobbling up an
+ * event, without letting the reader do any I/O to re-enable
+ * the notification.
+ */
+
+ (void) (*winSock.WSAAsyncSelect)(infoPtr->socket, winSock.hwnd,
+ SOCKET_MESSAGE, infoPtr->selectEvents);
+ }
+ }
+ if (events & FD_WRITE) {
+ 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;
+
+ /*
+ * 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 (winSock.hInstance != NULL) {
+
+ /*
+ * 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.
+ */
+
+ for (nextPtrPtr = &socketList; (*nextPtrPtr) != NULL;
+ nextPtrPtr = &((*nextPtrPtr)->nextPtr)) {
+ if ((*nextPtrPtr) == infoPtr) {
+ (*nextPtrPtr) = infoPtr->nextPtr;
+ break;
+ }
+ }
+ 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;
+
+ infoPtr = (SocketInfo *) ckalloc((unsigned) sizeof(SocketInfo));
+ infoPtr->socket = socket;
+ infoPtr->flags = 0;
+ infoPtr->watchEvents = 0;
+ infoPtr->readyEvents = 0;
+ infoPtr->selectEvents = 0;
+ infoPtr->acceptProc = NULL;
+ infoPtr->lastError = 0;
+ infoPtr->nextPtr = socketList;
+ socketList = infoPtr;
+ 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. */
+
+ /*
+ * 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 (winSock.hInstance == NULL) {
+ 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;
+ }
+
+ /*
+ * 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.
+ */
+
+ (void) (*winSock.WSAAsyncSelect)(infoPtr->socket, winSock.hwnd,
+ SOCKET_MESSAGE, infoPtr->selectEvents);
+
+ 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 (winSock.hInstance == NULL) {
+ 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? */
+{
+ MSG msg;
+ int result = 1;
+ int oldMode;
+
+ /*
+ * Be sure to disable event servicing so we are truly modal.
+ */
+
+ oldMode = Tcl_SetServiceMode(TCL_SERVICE_NONE);
+
+ while (!(infoPtr->readyEvents & events)) {
+ if (infoPtr->flags & SOCKET_ASYNC) {
+ if (!PeekMessage(&msg, winSock.hwnd, SOCKET_MESSAGE,
+ SOCKET_MESSAGE, PM_REMOVE)) {
+ *errorCodePtr = EWOULDBLOCK;
+ result = 0;
+ break;
+ }
+ } else {
+ /*
+ * Look for a socket event. Note that we will be getting
+ * events for all of Tcl's sockets, not just the one we wanted.
+ */
+
+ result = GetMessage(&msg, winSock.hwnd, SOCKET_MESSAGE,
+ SOCKET_MESSAGE);
+ if (result == -1) {
+ TclWinConvertError(GetLastError());
+ *errorCodePtr = Tcl_GetErrno();
+ result = 0;
+ break;
+ }
+
+ /*
+ * I don't think we can get a WM_QUIT during a tight modal
+ * loop, but just in case...
+ */
+
+ if (result == 0) {
+ panic("WaitForSocketEvent: Got WM_QUIT during modal loop!");
+ }
+ }
+
+ /*
+ * Dispatch the message and then check for an error on the socket.
+ */
+
+ infoPtr->lastError = 0;
+ DispatchMessage(&msg);
+ if (infoPtr->lastError) {
+ *errorCodePtr = infoPtr->lastError;
+ result = 0;
+ break;
+ }
+ }
+
+ (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[20];
+
+ if (TclHasSockets(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;
+ }
+
+ sprintf(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[20];
+
+ if (TclHasSockets(NULL) != TCL_OK) {
+ return NULL;
+ }
+
+ /*
+ * 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;
+ (void) (*winSock.WSAAsyncSelect)(infoPtr->socket, winSock.hwnd,
+ SOCKET_MESSAGE, infoPtr->selectEvents);
+
+ sprintf(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[20];
+
+ if (TclHasSockets(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;
+
+ sprintf(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[20];
+
+ /*
+ * 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.
+ */
+
+ infoPtr->readyEvents &= ~(FD_ACCEPT);
+
+ if (newSocket == INVALID_SOCKET) {
+ return;
+ }
+
+ /*
+ * 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);
+ (void) (*winSock.WSAAsyncSelect)(newInfoPtr->socket, winSock.hwnd,
+ SOCKET_MESSAGE, newInfoPtr->selectEvents);
+
+ sprintf(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;
+
+ *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 (winSock.hInstance == NULL) {
+ *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) {
+ if (infoPtr->readyEvents & (FD_CLOSE|FD_READ)) {
+ 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) {
+ return bytesRead;
+ }
+
+ /*
+ * 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;
+ return 0;
+ }
+
+ /*
+ * 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();
+ return -1;
+ }
+
+ } else if (infoPtr->flags & SOCKET_ASYNC) {
+ *errorCodePtr = EWOULDBLOCK;
+ return -1;
+ }
+
+ /*
+ * In the blocking case, wait until the file becomes readable
+ * or closed and try again.
+ */
+
+ if (!WaitForSocketEvent(infoPtr, FD_READ|FD_CLOSE, errorCodePtr)) {
+ return -1;
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+
+ *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 (winSock.hInstance == NULL) {
+ *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) {
+ 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;
+ return -1;
+ }
+ } else {
+ TclWinConvertWSAError(error);
+ *errorCodePtr = Tcl_GetErrno();
+ return -1;
+ }
+
+ /*
+ * In the blocking case, wait until the file becomes writable
+ * or closed and try again.
+ */
+
+ if (!WaitForSocketEvent(infoPtr, FD_WRITE|FD_CLOSE, errorCodePtr)) {
+ return -1;
+ }
+ }
+
+ 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[128];
+
+ /*
+ * 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 (winSock.hInstance == NULL) {
+ 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 == 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));
+ }
+ sprintf(buf, "%d", (*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));
+ }
+ sprintf(buf, "%d", (*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);
+ }
+
+ /*
+ * 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_GetChannelFile 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;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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;
+
+ if (message != SOCKET_MESSAGE) {
+ return DefWindowProc(hwnd, message, wParam, lParam);
+ }
+
+ event = WSAGETSELECTEVENT(lParam);
+ error = WSAGETSELECTERROR(lParam);
+ socket = (SOCKET) wParam;
+
+ /*
+ * Find the specified socket on the socket list and update its
+ * eventState flag.
+ */
+
+ for (infoPtr = socketList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
+ if (infoPtr->socket == socket) {
+ /*
+ * Update the socket state.
+ */
+
+ if (event & FD_CLOSE) {
+ infoPtr->readyEvents &= ~(FD_WRITE|FD_ACCEPT);
+ }
+ if (event & FD_CONNECT) {
+ /*
+ * The socket is now connected, so 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();
+ }
+
+ }
+ infoPtr->readyEvents |= event;
+ break;
+ }
+ }
+
+ /*
+ * Flush the Tcl event queue before returning to the event loop.
+ */
+
+ Tcl_ServiceAll();
+
+ 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;
+ char *p;
+
+ if (hostnameInitialized) {
+ return hostname;
+ }
+
+ if (TclHasSockets(NULL) == TCL_OK) {
+ if ((*winSock.gethostname)(hostname, sizeof(hostname)) == 0) {
+ hostnameInitialized = 1;
+ return hostname;
+ }
+ }
+ length = sizeof(hostname);
+ if (GetComputerName(hostname, &length) != 0) {
+ for (p = hostname; *p != '\0'; p++) {
+ if (isupper(*((unsigned char *) p))) {
+ *p = (char) tolower(*((unsigned char *) p));
+ }
+ }
+ } else {
+ hostname[0] = '\0';
+ }
+ hostnameInitialized = 1;
+ 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 PASCAL FAR
+TclWinGetSockOpt(SOCKET s, int level, int optname, char FAR * 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 (winSock.hInstance == NULL) {
+ return SOCKET_ERROR;
+ }
+
+ return (*winSock.getsockopt)(s, level, optname, optval, optlen);
+}
+
+int PASCAL FAR
+TclWinSetSockOpt(SOCKET s, int level, int optname, const char FAR * 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 (winSock.hInstance == NULL) {
+ return SOCKET_ERROR;
+ }
+
+ return (*winSock.setsockopt)(s, level, optname, optval, optlen);
+}
+
+u_short PASCAL FAR
+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 (winSock.hInstance == NULL) {
+ return (u_short) -1;
+ }
+
+ return (*winSock.ntohs)(netshort);
+}
+
+struct servent FAR * PASCAL FAR
+TclWinGetServByName(const char FAR * name, const char FAR * 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 (winSock.hInstance == NULL) {
+ return (struct servent FAR *) NULL;
+ }
+
+ return (*winSock.getservbyname)(name, proto);
+}
diff --git a/win/tclWinTest.c b/win/tclWinTest.c
new file mode 100644
index 0000000..cb61403
--- /dev/null
+++ b/win/tclWinTest.c
@@ -0,0 +1,130 @@
+/*
+ * 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.
+ *
+ * SCCS: @(#) tclWinTest.c 1.2 97/03/20 15:04:12
+ */
+
+#include "tclInt.h"
+#include "tclPort.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));
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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);
+ 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;
+}
diff --git a/win/tclWinTime.c b/win/tclWinTime.c
new file mode 100644
index 0000000..b59f68d
--- /dev/null
+++ b/win/tclWinTime.c
@@ -0,0 +1,373 @@
+/*
+ * tclWinTime.c --
+ *
+ * Contains Windows specific versions of Tcl functions that
+ * obtain time values from the operating system.
+ *
+ * Copyright 1995 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.
+ *
+ * SCCS: @(#) tclWinTime.c 1.6 97/04/14 17:25:56
+ */
+
+#include "tclInt.h"
+#include "tclPort.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
+};
+
+/*
+ * 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()
+{
+ tzset();
+ if (_daylight && _tzname[1] != NULL) {
+ return _tzname[1];
+ } else {
+ return _tzname[0];
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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(tp, useGMT)
+ const time_t *tp;
+ int useGMT;
+{
+ 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.
+ */
+
+ time = *tp - _timezone;
+ if (time >= 0) {
+ return localtime(tp);
+ }
+
+ /*
+ * 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 statically allocated struct tm.
+ *
+ * Side effects:
+ * Updates the values of the static struct tm.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static struct tm *
+ComputeGMT(tp)
+ const time_t *tp;
+{
+ static struct tm tm; /* This should be allocated per thread.*/
+ long tmp, rem;
+ int isLeap;
+ int *days;
+
+ /*
+ * 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;
+ }
+ }
+ }
+ tm.tm_year = tmp;
+
+ /*
+ * Compute the day of year and leave the seconds in the current day in
+ * the remainder.
+ */
+
+ tm.tm_yday = rem / SECSPERDAY;
+ rem %= SECSPERDAY;
+
+ /*
+ * Compute the time of day.
+ */
+
+ tm.tm_hour = rem / 3600;
+ rem %= 3600;
+ tm.tm_min = rem / 60;
+ tm.tm_sec = rem % 60;
+
+ /*
+ * Compute the month and day of month.
+ */
+
+ days = (isLeap) ? leapDays : normalDays;
+ for (tmp = 1; days[tmp] < tm.tm_yday; tmp++) {
+ }
+ tm.tm_mon = --tmp;
+ tm.tm_mday = tm.tm_yday - days[tmp];
+
+ /*
+ * Compute day of week. Epoch started on a Thursday.
+ */
+
+ tm.tm_wday = (*tp / SECSPERDAY) + 4;
+ if ((*tp % SECSPERDAY) < 0) {
+ tm.tm_wday--;
+ }
+ tm.tm_wday %= 7;
+ if (tm.tm_wday < 0) {
+ tm.tm_wday += 7;
+ }
+
+ return &tm;
+}
diff --git a/win/tclsh.rc b/win/tclsh.rc
new file mode 100644
index 0000000..e48c157
--- /dev/null
+++ b/win/tclsh.rc
@@ -0,0 +1,36 @@
+// SCCS: @(#) tclsh.rc 1.15 96/09/18 18:19:38
+//
+// Version
+//
+
+#define RESOURCE_INCLUDED
+#include <tcl.h>
+
+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 0x4L
+ FILETYPE 0x1L
+ 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", "Sun Microsystems, Inc\0"
+ VALUE "FileVersion", TCL_PATCH_LEVEL
+ VALUE "LegalCopyright", "Copyright \251 1995-1996\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/winDumpExts.c b/win/winDumpExts.c
new file mode 100644
index 0000000..8bc496e
--- /dev/null
+++ b/win/winDumpExts.c
@@ -0,0 +1,503 @@
+/*
+ * winDumpExts.c --
+ * Author: Gordon Chaffee, Scott Stanton
+ *
+ * History: The real functionality of this file was written by
+ * Matt Pietrek in 1993 in his pedump utility. I've
+ * modified it to dump the externals in a bunch of object
+ * files to create a .def file.
+ *
+ * 10/12/95 Modified by Scott Stanton to support Relocatable Object Module
+ * Format files for Borland C++ 4.5.
+ *
+ * Notes: Visual C++ puts an underscore before each exported symbol.
+ * This file removes them. I don't know if this is a problem
+ * this other compilers. If _MSC_VER is defined,
+ * the underscore is removed. If not, it isn't. To get a
+ * full dump of an object file, use the -f option. This can
+ * help determine the something that may be different with a
+ * compiler other than Visual C++.
+ *----------------------------------------------------------------------
+ *
+ * SCCS: @(#) winDumpExts.c 1.11 96/09/18 15:25:11
+ */
+
+#include <windows.h>
+#include <stdio.h>
+#include <string.h>
+#include <process.h>
+
+#ifdef _ALPHA_
+#define e_magic_number IMAGE_FILE_MACHINE_ALPHA
+#else
+#define e_magic_number IMAGE_FILE_MACHINE_I386
+#endif
+
+/*
+ *----------------------------------------------------------------------
+ * GetArgcArgv --
+ *
+ * Break up a line into argc argv
+ *----------------------------------------------------------------------
+ */
+int
+GetArgcArgv(char *s, char **argv)
+{
+ int quote = 0;
+ int argc = 0;
+ char *bp;
+
+ bp = s;
+ while (1) {
+ while (isspace(*bp)) {
+ bp++;
+ }
+ if (*bp == '\n' || *bp == '\0') {
+ *bp = '\0';
+ return argc;
+ }
+ if (*bp == '\"') {
+ quote = 1;
+ bp++;
+ }
+ argv[argc++] = bp;
+
+ while (*bp != '\0') {
+ if (quote) {
+ if (*bp == '\"') {
+ quote = 0;
+ *bp = '\0';
+ bp++;
+ break;
+ }
+ bp++;
+ continue;
+ }
+ if (isspace(*bp)) {
+ *bp = '\0';
+ bp++;
+ break;
+ }
+ bp++;
+ }
+ }
+}
+
+/*
+ * The names of the first group of possible symbol table storage classes
+ */
+char * SzStorageClass1[] = {
+ "NULL","AUTOMATIC","EXTERNAL","STATIC","REGISTER","EXTERNAL_DEF","LABEL",
+ "UNDEFINED_LABEL","MEMBER_OF_STRUCT","ARGUMENT","STRUCT_TAG",
+ "MEMBER_OF_UNION","UNION_TAG","TYPE_DEFINITION","UNDEFINED_STATIC",
+ "ENUM_TAG","MEMBER_OF_ENUM","REGISTER_PARAM","BIT_FIELD"
+};
+
+/*
+ * The names of the second group of possible symbol table storage classes
+ */
+char * SzStorageClass2[] = {
+ "BLOCK","FUNCTION","END_OF_STRUCT","FILE","SECTION","WEAK_EXTERNAL"
+};
+
+/*
+ *----------------------------------------------------------------------
+ * GetSZStorageClass --
+ *
+ * Given a symbol storage class value, return a descriptive
+ * ASCII string
+ *----------------------------------------------------------------------
+ */
+PSTR
+GetSZStorageClass(BYTE storageClass)
+{
+ if ( storageClass <= IMAGE_SYM_CLASS_BIT_FIELD )
+ return SzStorageClass1[storageClass];
+ else if ( (storageClass >= IMAGE_SYM_CLASS_BLOCK)
+ && (storageClass <= IMAGE_SYM_CLASS_WEAK_EXTERNAL) )
+ return SzStorageClass2[storageClass-IMAGE_SYM_CLASS_BLOCK];
+ else
+ return "???";
+}
+
+/*
+ *----------------------------------------------------------------------
+ * GetSectionName --
+ *
+ * Used by DumpSymbolTable, it gives meaningful names to
+ * the non-normal section number.
+ *
+ * Results:
+ * A name is returned in buffer
+ *----------------------------------------------------------------------
+ */
+void
+GetSectionName(WORD section, PSTR buffer, unsigned cbBuffer)
+{
+ char tempbuffer[10];
+
+ switch ( (SHORT)section )
+ {
+ case IMAGE_SYM_UNDEFINED: strcpy(tempbuffer, "UNDEF"); break;
+ case IMAGE_SYM_ABSOLUTE: strcpy(tempbuffer, "ABS "); break;
+ case IMAGE_SYM_DEBUG: strcpy(tempbuffer, "DEBUG"); break;
+ default: wsprintf(tempbuffer, "%-5X", section);
+ }
+
+ strncpy(buffer, tempbuffer, cbBuffer-1);
+}
+
+/*
+ *----------------------------------------------------------------------
+ * DumpSymbolTable --
+ *
+ * Dumps a COFF symbol table from an EXE or OBJ. We only use
+ * it to dump tables from OBJs.
+ *----------------------------------------------------------------------
+ */
+void
+DumpSymbolTable(PIMAGE_SYMBOL pSymbolTable, FILE *fout, unsigned cSymbols)
+{
+ unsigned i;
+ PSTR stringTable;
+ char sectionName[10];
+
+ fprintf(fout, "Symbol Table - %X entries (* = auxillary symbol)\n",
+ cSymbols);
+
+ fprintf(fout,
+ "Indx Name Value Section cAux Type Storage\n"
+ "---- -------------------- -------- ---------- ----- ------- --------\n");
+
+ /*
+ * The string table apparently starts right after the symbol table
+ */
+ stringTable = (PSTR)&pSymbolTable[cSymbols];
+
+ for ( i=0; i < cSymbols; i++ ) {
+ fprintf(fout, "%04X ", i);
+ if ( pSymbolTable->N.Name.Short != 0 )
+ fprintf(fout, "%-20.8s", pSymbolTable->N.ShortName);
+ else
+ fprintf(fout, "%-20s", stringTable + pSymbolTable->N.Name.Long);
+
+ fprintf(fout, " %08X", pSymbolTable->Value);
+
+ GetSectionName(pSymbolTable->SectionNumber, sectionName,
+ sizeof(sectionName));
+ fprintf(fout, " sect:%s aux:%X type:%02X st:%s\n",
+ sectionName,
+ pSymbolTable->NumberOfAuxSymbols,
+ pSymbolTable->Type,
+ GetSZStorageClass(pSymbolTable->StorageClass) );
+#if 0
+ if ( pSymbolTable->NumberOfAuxSymbols )
+ DumpAuxSymbols(pSymbolTable);
+#endif
+
+ /*
+ * Take into account any aux symbols
+ */
+ i += pSymbolTable->NumberOfAuxSymbols;
+ pSymbolTable += pSymbolTable->NumberOfAuxSymbols;
+ pSymbolTable++;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ * DumpExternals --
+ *
+ * Dumps a COFF symbol table from an EXE or OBJ. We only use
+ * it to dump tables from OBJs.
+ *----------------------------------------------------------------------
+ */
+void
+DumpExternals(PIMAGE_SYMBOL pSymbolTable, FILE *fout, unsigned cSymbols)
+{
+ unsigned i;
+ PSTR stringTable;
+ char *s, *f;
+ char symbol[1024];
+
+ /*
+ * The string table apparently starts right after the symbol table
+ */
+ stringTable = (PSTR)&pSymbolTable[cSymbols];
+
+ for ( i=0; i < cSymbols; i++ ) {
+ if (pSymbolTable->SectionNumber > 0 && pSymbolTable->Type == 0x20) {
+ if (pSymbolTable->StorageClass == IMAGE_SYM_CLASS_EXTERNAL) {
+ if (pSymbolTable->N.Name.Short != 0) {
+ strncpy(symbol, pSymbolTable->N.ShortName, 8);
+ symbol[8] = 0;
+ } else {
+ s = stringTable + pSymbolTable->N.Name.Long;
+ strcpy(symbol, s);
+ }
+ s = symbol;
+ f = strchr(s, '@');
+ if (f) {
+ *f = 0;
+ }
+#if defined(_MSC_VER) && defined(_X86_)
+ if (symbol[0] == '_') {
+ s = &symbol[1];
+ }
+#endif
+ if ((stricmp(s, "DllEntryPoint") != 0)
+ && (stricmp(s, "DllMain") != 0)) {
+ fprintf(fout, "\t%s\n", s);
+ }
+ }
+ }
+
+ /*
+ * Take into account any aux symbols
+ */
+ i += pSymbolTable->NumberOfAuxSymbols;
+ pSymbolTable += pSymbolTable->NumberOfAuxSymbols;
+ pSymbolTable++;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ * DumpObjFile --
+ *
+ * Dump an object file--either a full listing or just the exported
+ * symbols.
+ *----------------------------------------------------------------------
+ */
+void
+DumpObjFile(PIMAGE_FILE_HEADER pImageFileHeader, FILE *fout, int full)
+{
+ PIMAGE_SYMBOL PCOFFSymbolTable;
+ DWORD COFFSymbolCount;
+
+ PCOFFSymbolTable = (PIMAGE_SYMBOL)
+ ((DWORD)pImageFileHeader + pImageFileHeader->PointerToSymbolTable);
+ COFFSymbolCount = pImageFileHeader->NumberOfSymbols;
+
+ if (full) {
+ DumpSymbolTable(PCOFFSymbolTable, fout, COFFSymbolCount);
+ } else {
+ DumpExternals(PCOFFSymbolTable, fout, COFFSymbolCount);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ * SkipToNextRecord --
+ *
+ * Skip over the current ROMF record and return the type of the
+ * next record.
+ *----------------------------------------------------------------------
+ */
+
+BYTE
+SkipToNextRecord(BYTE **ppBuffer)
+{
+ int length;
+ (*ppBuffer)++; /* Skip over the type.*/
+ length = *((WORD*)(*ppBuffer))++; /* Retrieve the length. */
+ *ppBuffer += length; /* Skip over the rest. */
+ return **ppBuffer; /* Return the type. */
+}
+
+/*
+ *----------------------------------------------------------------------
+ * DumpROMFObjFile --
+ *
+ * Dump a Relocatable Object Module Format file, displaying only
+ * the exported symbols.
+ *----------------------------------------------------------------------
+ */
+void
+DumpROMFObjFile(LPVOID pBuffer, FILE *fout)
+{
+ BYTE type, length;
+ char symbol[1024], *s;
+
+ while (1) {
+ type = SkipToNextRecord(&(BYTE*)pBuffer);
+ if (type == 0x90) { /* PUBDEF */
+ if (((BYTE*)pBuffer)[4] != 0) {
+ length = ((BYTE*)pBuffer)[5];
+ strncpy(symbol, ((char*)pBuffer) + 6, length);
+ symbol[length] = '\0';
+ s = symbol;
+ if ((stricmp(s, "DllEntryPoint") != 0)
+ && (stricmp(s, "DllMain") != 0)) {
+ if (s[0] == '_') {
+ s++;
+ fprintf(fout, "\t_%s\n\t%s=_%s\n", s, s, s);
+ } else {
+ fprintf(fout, "\t%s\n", s);
+ }
+ }
+ }
+ } else if (type == 0x8B || type == 0x8A) { /* MODEND */
+ break;
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ * DumpFile --
+ *
+ * Open up a file, memory map it, and call the appropriate
+ * dumping routine
+ *----------------------------------------------------------------------
+ */
+void
+DumpFile(LPSTR filename, FILE *fout, int full)
+{
+ HANDLE hFile;
+ HANDLE hFileMapping;
+ LPVOID lpFileBase;
+ PIMAGE_DOS_HEADER dosHeader;
+
+ hFile = CreateFile(filename, GENERIC_READ, FILE_SHARE_READ, NULL,
+ OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
+
+ if (hFile == INVALID_HANDLE_VALUE) {
+ fprintf(stderr, "Couldn't open file with CreateFile()\n");
+ return;
+ }
+
+ hFileMapping = CreateFileMapping(hFile, NULL, PAGE_READONLY, 0, 0, NULL);
+ if (hFileMapping == 0) {
+ CloseHandle(hFile);
+ fprintf(stderr, "Couldn't open file mapping with CreateFileMapping()\n");
+ return;
+ }
+
+ lpFileBase = MapViewOfFile(hFileMapping, FILE_MAP_READ, 0, 0, 0);
+ if (lpFileBase == 0) {
+ CloseHandle(hFileMapping);
+ CloseHandle(hFile);
+ fprintf(stderr, "Couldn't map view of file with MapViewOfFile()\n");
+ return;
+ }
+
+ dosHeader = (PIMAGE_DOS_HEADER)lpFileBase;
+ if (dosHeader->e_magic == IMAGE_DOS_SIGNATURE) {
+#if 0
+ DumpExeFile( dosHeader );
+#else
+ fprintf(stderr, "File is an executable. I don't dump those.\n");
+ return;
+#endif
+ }
+ /* Does it look like a i386 COFF OBJ file??? */
+ else if ((dosHeader->e_magic == e_magic_number)
+ && (dosHeader->e_sp == 0)) {
+ /*
+ * The two tests above aren't what they look like. They're
+ * really checking for IMAGE_FILE_HEADER.Machine == i386 (0x14C)
+ * and IMAGE_FILE_HEADER.SizeOfOptionalHeader == 0;
+ */
+ DumpObjFile((PIMAGE_FILE_HEADER) lpFileBase, fout, full);
+ } else if (*((BYTE *)lpFileBase) == 0x80) {
+ /*
+ * This file looks like it might be a ROMF file.
+ */
+ DumpROMFObjFile(lpFileBase, fout);
+ } else {
+ printf("unrecognized file format\n");
+ }
+ UnmapViewOfFile(lpFileBase);
+ CloseHandle(hFileMapping);
+ CloseHandle(hFile);
+}
+
+void
+main(int argc, char **argv)
+{
+ char *fargv[1000];
+ char cmdline[10000];
+ int i, arg;
+ FILE *fout;
+ int pos;
+ int full = 0;
+ char *outfile = NULL;
+
+ if (argc < 3) {
+ Usage:
+ fprintf(stderr, "Usage: %s ?-o outfile? ?-f(ull)? <dllname> <object filenames> ..\n", argv[0]);
+ exit(1);
+ }
+
+ arg = 1;
+ while (argv[arg][0] == '-') {
+ if (strcmp(argv[arg], "--") == 0) {
+ arg++;
+ break;
+ } else if (strcmp(argv[arg], "-f") == 0) {
+ full = 1;
+ } else if (strcmp(argv[arg], "-o") == 0) {
+ arg++;
+ if (arg == argc) {
+ goto Usage;
+ }
+ outfile = argv[arg];
+ }
+ arg++;
+ }
+ if (arg == argc) {
+ goto Usage;
+ }
+
+ if (outfile) {
+ fout = fopen(outfile, "w+");
+ if (fout == NULL) {
+ fprintf(stderr, "Unable to open \'%s\' for writing:\n",
+ argv[arg]);
+ perror("");
+ exit(1);
+ }
+ } else {
+ fout = stdout;
+ }
+
+ if (! full) {
+ char *dllname = argv[arg];
+ arg++;
+ if (arg == argc) {
+ goto Usage;
+ }
+ fprintf(fout, "LIBRARY %s\n", dllname);
+ fprintf(fout, "EXETYPE WINDOWS\n");
+ fprintf(fout, "CODE PRELOAD MOVEABLE DISCARDABLE\n");
+ fprintf(fout, "DATA PRELOAD MOVEABLE MULTIPLE\n\n");
+ fprintf(fout, "EXPORTS\n");
+ }
+
+ for (; arg < argc; arg++) {
+ if (argv[arg][0] == '@') {
+ FILE *fargs = fopen(&argv[arg][1], "r");
+ if (fargs == NULL) {
+ fprintf(stderr, "Unable to open \'%s\' for reading:\n",
+ argv[arg]);
+ perror("");
+ exit(1);
+ }
+ pos = 0;
+ for (i = 0; i < arg; i++) {
+ strcpy(&cmdline[pos], argv[i]);
+ pos += strlen(&cmdline[pos]) + 1;
+ fargv[i] = argv[i];
+ }
+ fgets(&cmdline[pos], sizeof(cmdline), fargs);
+ fprintf(stderr, "%s\n", &cmdline[pos]);
+ fclose(fargs);
+ i += GetArgcArgv(&cmdline[pos], &fargv[i]);
+ argc = i;
+ argv = fargv;
+ }
+ DumpFile(argv[arg], fout, full);
+ }
+ exit(0);
+}