diff options
author | rjohnson <rjohnson> | 1998-03-26 14:56:55 (GMT) |
---|---|---|
committer | rjohnson <rjohnson> | 1998-03-26 14:56:55 (GMT) |
commit | 72d823b9193f9ee2b0318563b49363cd08c11f24 (patch) | |
tree | c168cc164a71f320db9dcdfe7518ba7bd0d2c8d9 /win | |
parent | 2b5738da524e944cda39e24c0a87b745a43bd8c3 (diff) | |
download | tcl-72d823b9193f9ee2b0318563b49363cd08c11f24.zip tcl-72d823b9193f9ee2b0318563b49363cd08c11f24.tar.gz tcl-72d823b9193f9ee2b0318563b49363cd08c11f24.tar.bz2 |
Initial revision
Diffstat (limited to 'win')
-rw-r--r-- | win/README | 109 | ||||
-rw-r--r-- | win/cat.c | 37 | ||||
-rw-r--r-- | win/makefile.bc | 387 | ||||
-rw-r--r-- | win/makefile.vc | 377 | ||||
-rw-r--r-- | win/pkgIndex.tcl | 11 | ||||
-rw-r--r-- | win/stub16.c | 198 | ||||
-rw-r--r-- | win/tcl.rc | 42 | ||||
-rw-r--r-- | win/tcl16.rc | 37 | ||||
-rw-r--r-- | win/tclAppInit.c | 259 | ||||
-rw-r--r-- | win/tclWin16.c | 347 | ||||
-rw-r--r-- | win/tclWin32Dll.c | 362 | ||||
-rw-r--r-- | win/tclWinChan.c | 1185 | ||||
-rw-r--r-- | win/tclWinError.c | 393 | ||||
-rw-r--r-- | win/tclWinFCmd.c | 1401 | ||||
-rw-r--r-- | win/tclWinFile.c | 647 | ||||
-rw-r--r-- | win/tclWinInit.c | 394 | ||||
-rw-r--r-- | win/tclWinInt.h | 38 | ||||
-rw-r--r-- | win/tclWinLoad.c | 114 | ||||
-rw-r--r-- | win/tclWinMtherr.c | 61 | ||||
-rw-r--r-- | win/tclWinNotify.c | 325 | ||||
-rw-r--r-- | win/tclWinPipe.c | 2470 | ||||
-rw-r--r-- | win/tclWinPort.h | 399 | ||||
-rw-r--r-- | win/tclWinReg.c | 1212 | ||||
-rw-r--r-- | win/tclWinSock.c | 2113 | ||||
-rw-r--r-- | win/tclWinTest.c | 130 | ||||
-rw-r--r-- | win/tclWinTime.c | 373 | ||||
-rw-r--r-- | win/tclsh.rc | 36 | ||||
-rw-r--r-- | win/winDumpExts.c | 503 |
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); +} |