summaryrefslogtreecommitdiffstats
path: root/win
diff options
context:
space:
mode:
authorstanton <stanton>1998-09-21 23:39:52 (GMT)
committerstanton <stanton>1998-09-21 23:39:52 (GMT)
commit494c2de3a748b449c69ce322a1a741f5a31fd4d5 (patch)
treec3ece48c0ae3f4ba54787e0e8e729b65752ef3f9 /win
parent7a698c0488d99c0af42022714638ae1ba2afaa49 (diff)
downloadtcl-494c2de3a748b449c69ce322a1a741f5a31fd4d5.zip
tcl-494c2de3a748b449c69ce322a1a741f5a31fd4d5.tar.gz
tcl-494c2de3a748b449c69ce322a1a741f5a31fd4d5.tar.bz2
Added contents of Tcl 8.1a2
Diffstat (limited to 'win')
-rw-r--r--win/README47
-rw-r--r--win/makefile.bc27
-rw-r--r--win/makefile.vc53
-rw-r--r--win/pkgIndex.tcl4
-rw-r--r--win/tcl.rc14
-rw-r--r--win/tclAppInit.c46
-rw-r--r--win/tclWin32Dll.c537
-rw-r--r--win/tclWinChan.c147
-rw-r--r--win/tclWinError.c5
-rw-r--r--win/tclWinFCmd.c1036
-rw-r--r--win/tclWinFile.c934
-rw-r--r--win/tclWinInit.c575
-rw-r--r--win/tclWinInt.h74
-rw-r--r--win/tclWinLoad.c77
-rw-r--r--win/tclWinMtherr.c15
-rw-r--r--win/tclWinNotify.c224
-rw-r--r--win/tclWinPipe.c1465
-rw-r--r--win/tclWinPort.h391
-rw-r--r--win/tclWinReg.c57
-rw-r--r--win/tclWinSock.c559
-rw-r--r--win/tclWinTest.c5
-rw-r--r--win/tclWinThrd.c724
-rw-r--r--win/tclWinThrd.h21
-rw-r--r--win/tclWinTime.c116
-rw-r--r--win/tclsh.rc10
25 files changed, 4991 insertions, 2172 deletions
diff --git a/win/README b/win/README
index 0e3550b..60f15ab 100644
--- a/win/README
+++ b/win/README
@@ -1,10 +1,6 @@
-Tcl 8.0p2 for Windows
+Tcl 8.1a2 for Windows
-by Scott Stanton
-Sun Microsystems Laboratories
-scott.stanton@eng.sun.com
-
-SCCS: @(#) README 1.25 97/11/21 15:15:40
+SCCS: @(#) README 1.28 98/02/18 15:11:13
1. Introduction
---------------
@@ -17,12 +13,12 @@ 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
+Tcl 8.1 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,
+(ftp.sunlabs.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
@@ -34,12 +30,12 @@ source distribution in order to build and use extensions.
In order to compile Tcl for Windows, you need the following items:
- Tcl 8.0 Source Distribution (plus any patches)
+ Tcl 8.1 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)
+ Visual C++ 1.5 (to build tcl1681.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
@@ -55,23 +51,23 @@ 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
+ 2) In the lib\tcl8.1 directory under the installation directory
as specified in the registry:
For Windows NT & 95:
- HKEY_LOCAL_MACHINE\SOFTWARE\Sun\Tcl\8.0
+ HKEY_LOCAL_MACHINE\SOFTWARE\Sun\Tcl\8.1
Value Name is "Root"
For Win32s:
- HKEY_CLASSES_ROOT\SOFTWARE\Sun\Tcl\8.0\
+ HKEY_CLASSES_ROOT\SOFTWARE\Sun\Tcl\8.1\
3) Relative to the directory containing the current .exe.
- Tcl will look for a directory "..\lib\tcl8.0" relative to the
+ Tcl will look for a directory "..\lib\tcl8.1" 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.
+Note that in order to run tclsh81.exe, you must ensure that tcl81.dll
+and tclpip81.dll (plus tcl1681.dll under Win32s) are on your path, in
+the system directory, or in the directory containing tclsh81.exe.
4. Test suite
-------------
@@ -95,15 +91,14 @@ Windows version of Tcl:
- 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.
+- File events only work on sockets and 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.
+- Environment variables containing international characters aren't
+ imported correctly.
-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.
+If you have comments or bug reports for the Windows version of Tk,
+please direct them to the comp.lang.tcl newsgroup or the wintcl
+mailing list (see http://sunscript.sun.com/win/wintcl-list.html for
+more information).
diff --git a/win/makefile.bc b/win/makefile.bc
index c0c9740..3436b5c 100644
--- a/win/makefile.bc
+++ b/win/makefile.bc
@@ -1,5 +1,5 @@
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
-# SCCS: @(#) makefile.bc 1.82 97/11/20 15:52:39
+# SCCS: @(#) makefile.bc 1.88 98/02/19 16:49:06
#
# Borland C++ 4.5 makefile
#
@@ -33,7 +33,7 @@ TOOLS = c:\bc45
STACKSIZE = 1f0001
-VERSION = 80
+VERSION = 81
TCLLIB = tcl$(VERSION).lib
TCLDLL = tcl$(VERSION).dll
@@ -52,12 +52,14 @@ TCLSHOBJS = \
TCLTESTOBJS = \
$(TMPDIR)\tclTest.obj \
$(TMPDIR)\tclTestObj.obj \
+ $(TMPDIR)\tclThreadTest.obj \
$(TMPDIR)\tclWinTest.obj \
$(TMPDIR)\testMain.obj
TCLOBJS = \
+ $(TMPDIR)\compile.obj \
+ $(TMPDIR)\exec.obj \
$(TMPDIR)\panic.obj \
- $(TMPDIR)\regexp.obj \
$(TMPDIR)\strftime.obj \
$(TMPDIR)\tclAlloc.obj \
$(TMPDIR)\tclAsync.obj \
@@ -68,9 +70,11 @@ TCLOBJS = \
$(TMPDIR)\tclCmdAH.obj \
$(TMPDIR)\tclCmdIL.obj \
$(TMPDIR)\tclCmdMZ.obj \
+ $(TMPDIR)\tclCompCmds.obj \
$(TMPDIR)\tclCompExpr.obj \
$(TMPDIR)\tclCompile.obj \
$(TMPDIR)\tclDate.obj \
+ $(TMPDIR)\tclEncoding.obj \
$(TMPDIR)\tclEnv.obj \
$(TMPDIR)\tclEvent.obj \
$(TMPDIR)\tclExecute.obj \
@@ -86,6 +90,7 @@ TCLOBJS = \
$(TMPDIR)\tclIOSock.obj \
$(TMPDIR)\tclIOUtil.obj \
$(TMPDIR)\tclLink.obj \
+ $(TMPDIR)\tclLiteral.obj \
$(TMPDIR)\tclListObj.obj \
$(TMPDIR)\tclLoad.obj \
$(TMPDIR)\tclMain.obj \
@@ -93,13 +98,18 @@ TCLOBJS = \
$(TMPDIR)\tclNotify.obj \
$(TMPDIR)\tclObj.obj \
$(TMPDIR)\tclParse.obj \
+ $(TMPDIR)\tclParseExpr.obj \
$(TMPDIR)\tclPipe.obj \
$(TMPDIR)\tclPkg.obj \
$(TMPDIR)\tclPosixStr.obj \
$(TMPDIR)\tclPreserve.obj \
$(TMPDIR)\tclProc.obj \
+ $(TMPDIR)\tclRegexp.obj \
+ $(TMPDIR)\tclResult.obj \
$(TMPDIR)\tclStringObj.obj \
+ $(TMPDIR)\tclThread.obj \
$(TMPDIR)\tclTimer.obj \
+ $(TMPDIR)\tclUtf.obj \
$(TMPDIR)\tclUtil.obj \
$(TMPDIR)\tclVar.obj \
$(TMPDIR)\tclWin32Dll.obj \
@@ -113,17 +123,17 @@ TCLOBJS = \
$(TMPDIR)\tclWinNotify.obj \
$(TMPDIR)\tclWinPipe.obj \
$(TMPDIR)\tclWinSock.obj \
- $(TMPDIR)\tclWinTime.obj
+ $(TMPDIR)\tclWinThrd.obj \
+ $(TMPDIR)\tclWinTime.obj
+cc16 = $(TOOLS)\bin\bcc.exe
cc32 = $(TOOLS)\bin\bcc32.exe
+link16 = $(TOOLS)\bin\tlink.exe
link32 = $(TOOLS)\bin\tlink32.exe
+rc16 = $(TOOLS)\bin\brcc32.exe -31
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
@@ -195,7 +205,6 @@ test: tcltest
source all
|
-
$(DUMPEXTS): cfgexe.cfg $(WINDIR)\winDumpExts.c
$(cc32) $(CON_CFLAGS) $(WINDIR)\winDumpExts.c
$(link32) $(CON_LFLAGS) \
diff --git a/win/makefile.vc b/win/makefile.vc
index 12eda6f..7bdfff4 100644
--- a/win/makefile.vc
+++ b/win/makefile.vc
@@ -4,7 +4,7 @@
# 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
+# SCCS: @(#) makefile.vc 1.91 98/02/18 15:07:56
# Does not depend on the presence of any environment variables in
# order to compile tcl; all needed information is derived from
@@ -26,7 +26,7 @@
# 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
+# A. Under Windows 3.X 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.
@@ -40,21 +40,26 @@ 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 the following line to compile with debugging symbols:
+#DEBUG=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
+# Uncomment the following line to compile with thread support
+#THREADDEFINES = -DTCL_THREADS=1
+
+# The following defines can be added to enable various options in the
+# way Tcl is built:
+#
+# TCL_MEM_DEBUG - enable the debugging memory allocator
+# TCL_COMPILE_DEBUG - enable the debugging bytecode compiler
+# TCL_COMPILE_STATS - enable statistics gathering in the bytecode compiler
+#
#DEBUGDEFINES = -DTCL_MEM_DEBUG -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS
######################################################################
# Do not modify below this line
######################################################################
-VERSION = 80
+VERSION = 81
TCLLIB = tcl$(VERSION).lib
TCLDLL = tcl$(VERSION).dll
@@ -76,12 +81,14 @@ TCLSHOBJS = \
TCLTESTOBJS = \
$(TMPDIR)\tclTest.obj \
$(TMPDIR)\tclTestObj.obj \
+ $(TMPDIR)\tclThreadTest.obj \
$(TMPDIR)\tclWinTest.obj \
$(TMPDIR)\testMain.obj
TCLOBJS = \
+ $(TMPDIR)\compile.obj \
+ $(TMPDIR)\exec.obj \
$(TMPDIR)\panic.obj \
- $(TMPDIR)\regexp.obj \
$(TMPDIR)\strftime.obj \
$(TMPDIR)\tclAlloc.obj \
$(TMPDIR)\tclAsync.obj \
@@ -92,9 +99,11 @@ TCLOBJS = \
$(TMPDIR)\tclCmdAH.obj \
$(TMPDIR)\tclCmdIL.obj \
$(TMPDIR)\tclCmdMZ.obj \
+ $(TMPDIR)\tclCompCmds.obj \
$(TMPDIR)\tclCompExpr.obj \
$(TMPDIR)\tclCompile.obj \
$(TMPDIR)\tclDate.obj \
+ $(TMPDIR)\tclEncoding.obj \
$(TMPDIR)\tclEnv.obj \
$(TMPDIR)\tclEvent.obj \
$(TMPDIR)\tclExecute.obj \
@@ -110,6 +119,7 @@ TCLOBJS = \
$(TMPDIR)\tclIOSock.obj \
$(TMPDIR)\tclIOUtil.obj \
$(TMPDIR)\tclLink.obj \
+ $(TMPDIR)\tclLiteral.obj \
$(TMPDIR)\tclListObj.obj \
$(TMPDIR)\tclLoad.obj \
$(TMPDIR)\tclMain.obj \
@@ -117,13 +127,18 @@ TCLOBJS = \
$(TMPDIR)\tclNotify.obj \
$(TMPDIR)\tclObj.obj \
$(TMPDIR)\tclParse.obj \
+ $(TMPDIR)\tclParseExpr.obj \
$(TMPDIR)\tclPipe.obj \
$(TMPDIR)\tclPkg.obj \
$(TMPDIR)\tclPosixStr.obj \
$(TMPDIR)\tclPreserve.obj \
$(TMPDIR)\tclProc.obj \
+ $(TMPDIR)\tclRegexp.obj \
+ $(TMPDIR)\tclResult.obj \
$(TMPDIR)\tclStringObj.obj \
+ $(TMPDIR)\tclThread.obj \
$(TMPDIR)\tclTimer.obj \
+ $(TMPDIR)\tclUtf.obj \
$(TMPDIR)\tclUtil.obj \
$(TMPDIR)\tclVar.obj \
$(TMPDIR)\tclWin32Dll.obj \
@@ -137,6 +152,7 @@ TCLOBJS = \
$(TMPDIR)\tclWinNotify.obj \
$(TMPDIR)\tclWinPipe.obj \
$(TMPDIR)\tclWinSock.obj \
+ $(TMPDIR)\tclWinThrd.obj \
$(TMPDIR)\tclWinTime.obj
cc32 = $(TOOLS32)\bin\cl.exe
@@ -153,7 +169,7 @@ WINDIR = $(ROOT)\win
GENERICDIR = $(ROOT)\generic
TCL_INCLUDES = -I$(WINDIR) -I$(GENERICDIR)
-TCL_DEFINES = -D__WIN32__ $(DEBUGDEFINES)
+TCL_DEFINES = -D__WIN32__ $(DEBUGDEFINES) $(THREADDEFINES)
TCL_CFLAGS = $(cdebug) $(cflags) $(cvarsdll) $(include32) \
$(TCL_INCLUDES) $(TCL_DEFINES)
@@ -165,10 +181,10 @@ DLL16_CFLAGS = $(cdebug) $(cflags) $(include16) -ALw
# Link flags
######################################################################
-!IFDEF NODEBUG
-ldebug = /RELEASE
-!ELSE
+!IF "$(DEBUG)" == "1"
ldebug = -debug:full -debugtype:cv
+!ELSE
+ldebug = /RELEASE
!ENDIF
# declarations common to all linker options
@@ -206,10 +222,11 @@ conlibsdll = $(libcdll) $(baselibs)
# Compile flags
######################################################################
-!IFDEF NODEBUG
-cdebug = -Oti -Gs -GD
+!IF "$(DEBUG)" == "1"
+#cdebug = -Z7 -Od -WX
+cdebug = -Z7 -Od
!ELSE
-cdebug = -Z7 -Od -WX
+cdebug = -Oti -Gs -GD
!ENDIF
# declarations common to all compiler options
diff --git a/win/pkgIndex.tcl b/win/pkgIndex.tcl
index 6847aa8..be61b0a 100644
--- a/win/pkgIndex.tcl
+++ b/win/pkgIndex.tcl
@@ -6,6 +6,6 @@
# 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
+# SCCS: @(#) pkgIndex.tcl 1.2 97/08/22 11:13:05
-package ifneeded registry 1.0 [list tclPkgSetup $dir registry 1.0 {{tclreg80.dll load registry}}]
+package ifneeded registry 1.0 [list tclPkgSetup $dir registry 1.0 {{tclreg81.dll load registry}}]
diff --git a/win/tcl.rc b/win/tcl.rc
index e7eabd1..dfc6cac 100644
--- a/win/tcl.rc
+++ b/win/tcl.rc
@@ -1,4 +1,4 @@
-// SCCS: @(#) tcl.rc 1.24 97/04/01 19:19:43
+// SCCS: @(#) tcl.rc 1.26 98/01/20 19:38:38
//
// Version
//
@@ -6,27 +6,29 @@
#define RESOURCE_INCLUDED
#include <tcl.h>
+LANGUAGE 0x9, 0x1 /* LANG_ENGLISH, SUBLANG_DEFAULT */
+
VS_VERSION_INFO VERSIONINFO
FILEVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL
PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL
FILEFLAGSMASK 0x3fL
FILEFLAGS 0x0L
- FILEOS 0x4L
- FILETYPE 0x2L
+ FILEOS 0x4 /* VOS__WINDOWS32 */
+ FILETYPE 0x2 /* VFT_DLL */
FILESUBTYPE 0x0L
BEGIN
BLOCK "StringFileInfo"
BEGIN
- BLOCK "040904b0"
+ BLOCK "040904b0" /* LANG_ENGLISH/SUBLANG_ENGLISH_US, Unicode CP */
BEGIN
VALUE "FileDescription", "Tcl DLL\0"
VALUE "OriginalFilename", "tcl" STRINGIFY(TCL_MAJOR_VERSION) STRINGIFY(TCL_MINOR_VERSION) ".dll\0"
VALUE "CompanyName", "Sun Microsystems, Inc\0"
VALUE "FileVersion", TCL_PATCH_LEVEL
- VALUE "LegalCopyright", "Copyright \251 1995-1997\0"
+ VALUE "LegalCopyright", "Copyright (c) 1995-1997\0"
VALUE "ProductName", "Tcl " TCL_VERSION " for Windows\0"
VALUE "ProductVersion", TCL_PATCH_LEVEL
- END
+ END
END
BLOCK "VarFileInfo"
BEGIN
diff --git a/win/tclAppInit.c b/win/tclAppInit.c
index 10a77cb..a84e9c4 100644
--- a/win/tclAppInit.c
+++ b/win/tclAppInit.c
@@ -5,12 +5,12 @@
* 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.
+ * 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: @(#) tclAppInit.c 1.12 97/04/30 11:04:50
+ * SCCS: @(#) tclAppInit.c 1.20 98/02/19 15:23:43
*/
#include "tcl.h"
@@ -20,6 +20,9 @@
#ifdef TCL_TEST
EXTERN int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN int TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp));
+#ifdef TCL_THREADS
+EXTERN int TclThread_Init _ANSI_ARGS_((Tcl_Interp *interp));
+#endif
#endif /* TCL_TEST */
static void setargv _ANSI_ARGS_((int *argcPtr, char ***argvPtr));
@@ -47,31 +50,14 @@ 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. */
}
@@ -88,7 +74,7 @@ main(argc, argv)
*
* Results:
* Returns a standard Tcl completion code, and leaves an error
- * message in interp->result if an error occurs.
+ * message in the interp's result if an error occurs.
*
* Side effects:
* Depends on the startup script.
@@ -113,6 +99,11 @@ Tcl_AppInit(interp)
if (TclObjTest_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
+#ifdef TCL_THREADS
+ if (TclThread_Init(interp) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+#endif
#endif /* TCL_TEST */
/*
@@ -178,7 +169,7 @@ setargv(argcPtr, argvPtr)
char **argv;
int argc, size, inquote, copy, slashes;
- cmdLine = GetCommandLine();
+ cmdLine = GetCommandLine(); /* INTL: BUG */
/*
* Precompute an overly pessimistic guess at the number of arguments
@@ -187,9 +178,9 @@ setargv(argcPtr, argvPtr)
size = 2;
for (p = cmdLine; *p != '\0'; p++) {
- if (isspace(*p)) {
+ if ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */
size++;
- while (isspace(*p)) {
+ while ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */
p++;
}
if (*p == '\0') {
@@ -197,8 +188,8 @@ setargv(argcPtr, argvPtr)
}
}
}
- argSpace = (char *) ckalloc((unsigned) (size * sizeof(char *)
- + strlen(cmdLine) + 1));
+ argSpace = (char *) Tcl_Alloc(
+ (unsigned) (size * sizeof(char *) + strlen(cmdLine) + 1));
argv = (char **) argSpace;
argSpace += size * sizeof(char *);
size--;
@@ -206,7 +197,7 @@ setargv(argcPtr, argvPtr)
p = cmdLine;
for (argc = 0; argc < size; argc++) {
argv[argc] = arg = argSpace;
- while (isspace(*p)) {
+ while ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */
p++;
}
if (*p == '\0') {
@@ -240,7 +231,8 @@ setargv(argcPtr, argvPtr)
slashes--;
}
- if ((*p == '\0') || (!inquote && isspace(*p))) {
+ if ((*p == '\0')
+ || (!inquote && ((*p == ' ') || (*p == '\t')))) { /* INTL: ISO space. */
break;
}
if (copy != 0) {
diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c
index 3abc97e..acb431f 100644
--- a/win/tclWin32Dll.c
+++ b/win/tclWin32Dll.c
@@ -9,50 +9,124 @@
* 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
+ * SCCS: @(#) tclWin32Dll.c 1.37 98/02/02 22:07:20
*/
#include "tclWinInt.h"
-typedef DWORD (WINAPI * UT32PROC)(LPVOID lpBuff, DWORD dwUserDefined,
+/*
+ * The following data structures are used when loading the thunking
+ * library for execing child processes under Win32s.
+ */
+
+typedef DWORD (WINAPI UT32PROC)(LPVOID lpBuff, DWORD dwUserDefined,
LPVOID *lpTranslationList);
-typedef BOOL (WINAPI * PUTREGISTER)(HANDLE hModule, LPCSTR SixteenBitDLL,
- LPCSTR InitName, LPCSTR ProcName, UT32PROC* ThirtyTwoBitThunk,
+typedef BOOL (WINAPI UTREGISTER)(HANDLE hModule, LPCSTR SixteenBitDLL,
+ LPCSTR InitName, LPCSTR ProcName, UT32PROC **ThirtyTwoBitThunk,
FARPROC UT32Callback, LPVOID Buff);
-typedef VOID (WINAPI * PUTUNREGISTER)(HANDLE hModule);
+typedef VOID (WINAPI UTUNREGISTER)(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.
+/*
+ * The following variables keep track of information about this DLL
+ * on a per-instance basis. Each time this DLL is loaded, it gets its own
+ * new data segment with its own copy of all static and global information.
*/
-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? */
+static HINSTANCE hInstance; /* HINSTANCE of this DLL. */
+static int platformId; /* Running under NT, 95, or Win32s? */
/*
- * Declarations for functions that are only used in this file.
+ * The following function tables are used to dispatch to either the
+ * wide-character or multi-byte versions of the operating system calls,
+ * depending on whether the Unicode calls are available.
*/
-static void UnloadLibraries _ANSI_ARGS_((void));
+static TclWinProcs asciiProcs = {
+ 0,
+
+ (BOOL (WINAPI *)(CONST TCHAR *, LPDCB)) BuildCommDCBA,
+ (TCHAR *(WINAPI *)(TCHAR *)) CharLowerA,
+ (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *, BOOL)) CopyFileA,
+ (BOOL (WINAPI *)(CONST TCHAR *, LPSECURITY_ATTRIBUTES)) CreateDirectoryA,
+ (HANDLE (WINAPI *)(CONST TCHAR *, DWORD, DWORD, SECURITY_ATTRIBUTES *,
+ DWORD, DWORD, HANDLE)) CreateFileA,
+ (BOOL (WINAPI *)(CONST TCHAR *, TCHAR *, LPSECURITY_ATTRIBUTES,
+ LPSECURITY_ATTRIBUTES, BOOL, DWORD, LPVOID, CONST TCHAR *,
+ LPSTARTUPINFOA, LPPROCESS_INFORMATION)) CreateProcessA,
+ (BOOL (WINAPI *)(CONST TCHAR *)) DeleteFileA,
+ (HANDLE (WINAPI *)(CONST TCHAR *, WIN32_FIND_DATAT *)) FindFirstFileA,
+ (BOOL (WINAPI *)(HANDLE, WIN32_FIND_DATAT *)) FindNextFileA,
+ (BOOL (WINAPI *)(WCHAR *, LPDWORD)) GetComputerNameA,
+ (DWORD (WINAPI *)(DWORD, WCHAR *)) GetCurrentDirectoryA,
+ (DWORD (WINAPI *)(CONST TCHAR *)) GetFileAttributesA,
+ (DWORD (WINAPI *)(CONST TCHAR *, DWORD nBufferLength, WCHAR *,
+ TCHAR **)) GetFullPathNameA,
+ (DWORD (WINAPI *)(HMODULE, WCHAR *, int)) GetModuleFileNameA,
+ (DWORD (WINAPI *)(CONST TCHAR *, WCHAR *, DWORD)) GetShortPathNameA,
+ (UINT (WINAPI *)(CONST TCHAR *, CONST TCHAR *, UINT uUnique,
+ WCHAR *)) GetTempFileNameA,
+ (DWORD (WINAPI *)(DWORD, WCHAR *)) GetTempPathA,
+ (BOOL (WINAPI *)(CONST TCHAR *, WCHAR *, DWORD, LPDWORD, LPDWORD, LPDWORD,
+ WCHAR *, DWORD)) GetVolumeInformationA,
+ (HINSTANCE (WINAPI *)(CONST TCHAR *)) LoadLibraryA,
+ (TCHAR (WINAPI *)(WCHAR *, CONST TCHAR *)) lstrcpyA,
+ (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *)) MoveFileA,
+ (BOOL (WINAPI *)(CONST TCHAR *)) RemoveDirectoryA,
+ (DWORD (WINAPI *)(CONST TCHAR *, CONST TCHAR *, CONST TCHAR *, DWORD,
+ WCHAR *, TCHAR **)) SearchPathA,
+ (BOOL (WINAPI *)(CONST TCHAR *)) SetCurrentDirectoryA,
+ (BOOL (WINAPI *)(CONST TCHAR *, DWORD)) SetFileAttributesA,
+};
+
+static TclWinProcs unicodeProcs = {
+ 1,
+
+ (BOOL (WINAPI *)(CONST TCHAR *, LPDCB)) BuildCommDCBW,
+ (TCHAR *(WINAPI *)(TCHAR *)) CharLowerW,
+ (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *, BOOL)) CopyFileW,
+ (BOOL (WINAPI *)(CONST TCHAR *, LPSECURITY_ATTRIBUTES)) CreateDirectoryW,
+ (HANDLE (WINAPI *)(CONST TCHAR *, DWORD, DWORD, SECURITY_ATTRIBUTES *,
+ DWORD, DWORD, HANDLE)) CreateFileW,
+ (BOOL (WINAPI *)(CONST TCHAR *, TCHAR *, LPSECURITY_ATTRIBUTES,
+ LPSECURITY_ATTRIBUTES, BOOL, DWORD, LPVOID, CONST TCHAR *,
+ LPSTARTUPINFOA, LPPROCESS_INFORMATION)) CreateProcessW,
+ (BOOL (WINAPI *)(CONST TCHAR *)) DeleteFileW,
+ (HANDLE (WINAPI *)(CONST TCHAR *, WIN32_FIND_DATAT *)) FindFirstFileW,
+ (BOOL (WINAPI *)(HANDLE, WIN32_FIND_DATAT *)) FindNextFileW,
+ (BOOL (WINAPI *)(WCHAR *, LPDWORD)) GetComputerNameW,
+ (DWORD (WINAPI *)(DWORD, WCHAR *)) GetCurrentDirectoryW,
+ (DWORD (WINAPI *)(CONST TCHAR *)) GetFileAttributesW,
+ (DWORD (WINAPI *)(CONST TCHAR *, DWORD nBufferLength, WCHAR *,
+ TCHAR **)) GetFullPathNameW,
+ (DWORD (WINAPI *)(HMODULE, WCHAR *, int)) GetModuleFileNameW,
+ (DWORD (WINAPI *)(CONST TCHAR *, WCHAR *, DWORD)) GetShortPathNameW,
+ (UINT (WINAPI *)(CONST TCHAR *, CONST TCHAR *, UINT uUnique,
+ WCHAR *)) GetTempFileNameW,
+ (DWORD (WINAPI *)(DWORD, WCHAR *)) GetTempPathW,
+ (BOOL (WINAPI *)(CONST TCHAR *, WCHAR *, DWORD, LPDWORD, LPDWORD, LPDWORD,
+ WCHAR *, DWORD)) GetVolumeInformationW,
+ (HINSTANCE (WINAPI *)(CONST TCHAR *)) LoadLibraryW,
+ (TCHAR (WINAPI *)(WCHAR *, CONST TCHAR *)) lstrcpyW,
+ (BOOL (WINAPI *)(CONST TCHAR *, CONST TCHAR *)) MoveFileW,
+ (BOOL (WINAPI *)(CONST TCHAR *)) RemoveDirectoryW,
+ (DWORD (WINAPI *)(CONST TCHAR *, CONST TCHAR *, CONST TCHAR *, DWORD,
+ WCHAR *, TCHAR **)) SearchPathW,
+ (BOOL (WINAPI *)(CONST TCHAR *)) SetCurrentDirectoryW,
+ (BOOL (WINAPI *)(CONST TCHAR *, DWORD)) SetFileAttributesW,
+};
+
+TclWinProcs *tclWinProcs;
+static Tcl_Encoding tclWinTCharEncoding;
/*
- * The following declaration is for the VC++ DLL entry point.
+ * Declarations for functions that are only used in this file.
*/
-BOOL APIENTRY DllMain _ANSI_ARGS_((HINSTANCE hInst,
- DWORD reason, LPVOID reserved));
+BOOL APIENTRY DllMain(HINSTANCE hInst, DWORD reason,
+ LPVOID reserved);
+
/*
*----------------------------------------------------------------------
@@ -108,63 +182,29 @@ DllMain(hInst, reason, reserved)
switch (reason) {
case DLL_PROCESS_ATTACH:
+ if (hInstance != NULL) {
+ /*
+ * Prevents DLL from being loaded multiple times under Win32s,
+ * since all copies of the DLL share the same data segment and
+ * Tcl isn't set up to handle that. Under NT or 95, each time
+ * the DLL is loaded, it gets its own private copy of the data
+ * segment.
+ */
- /*
- * 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. */
+ return FALSE;
}
- tclInstance = hInst;
- os.dwOSVersionInfoSize = sizeof(os);
+ hInstance = 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);
- }
+ platformId = os.dwPlatformId;
+ tclWinProcs = &asciiProcs;
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();
+ if (hInst == hInstance) {
+ Tcl_Finalize();
}
break;
}
@@ -175,73 +215,6 @@ DllMain(hInst, reason, reserved)
/*
*----------------------------------------------------------------------
*
- * 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.
@@ -257,59 +230,59 @@ UnloadLibraries()
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;
+ UTREGISTER *utRegisterProc;
+ UTUNREGISTER *utUnRegisterProc;
+ UT32PROC *ut32Proc;
+ char buffer[] = "TCL16xx.DLL";
+
+ hKernel = LoadLibraryA("kernel32.dll");
+ if (hKernel == NULL) {
+ return 0;
+ }
- HINSTANCE hKernel;
- PUTREGISTER UTRegister;
- char buffer[] = "TCL16xx.DLL";
+ /*
+ * Load the Universal Thunking routines from kernel32.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;
- }
+ utRegisterProc = (UTREGISTER *) GetProcAddress(hKernel, "UTRegister");
+ utUnRegisterProc = (UTUNREGISTER *) GetProcAddress(hKernel, "UTUnRegister");
+ if ((utRegisterProc == NULL) || (utUnRegisterProc == NULL)) {
+ FreeLibrary(hKernel);
+ return 0;
+ }
- /*
- * Construct the complete name of tcl16xx.dll.
- */
+ /*
+ * Construct the complete name of tcl16xx.dll.
+ */
- buffer[5] = '0' + TCL_MAJOR_VERSION;
- buffer[6] = '0' + TCL_MINOR_VERSION;
+ buffer[5] = '0' + TCL_MAJOR_VERSION;
+ buffer[6] = '0' + TCL_MINOR_VERSION;
- /*
- * Register the Tcl thunk.
- */
+ /*
+ * Register the Tcl thunk.
+ */
- if (UTRegister(tclInstance, buffer, NULL, "UTProc", &UTProc, NULL,
- NULL) == FALSE) {
- utErrorCode = GetLastError();
- }
+ if ((*utRegisterProc)(hInstance, buffer, NULL, "UTProc", &ut32Proc,
+ NULL, NULL) == FALSE) {
+ FreeLibrary(hKernel);
+ return 0;
}
-
- if (UTProc == NULL) {
+ if (ut32Proc == NULL) {
/*
* The 16-bit thunking DLL wasn't found. Return error code that
* indicates this problem.
*/
- SetLastError(utErrorCode);
+ (*utUnRegisterProc)(hInstance);
+ FreeLibrary(hKernel);
return 0;
}
- UTProc(args, type, trans);
*pidPtr = 0;
+ (*ut32Proc)(args, type, trans);
+ (*utUnRegisterProc)(hInstance);
+ FreeLibrary(hKernel);
return 1;
}
@@ -332,7 +305,7 @@ TclWinSynchSpawn(void *args, int type, void **trans, Tcl_Pid *pidPtr)
HINSTANCE
TclWinGetTclInstance()
{
- return tclInstance;
+ return hInstance;
}
/*
@@ -358,5 +331,209 @@ TclWinGetTclInstance()
int
TclWinGetPlatformId()
{
- return tclPlatformId;
+ return platformId;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclWinNoBackslash --
+ *
+ * We're always iterating through a string in Windows, changing the
+ * backslashes to slashes for use in Tcl.
+ *
+ * Results:
+ * All backslashes in given string are changes to slashes.
+ *
+ * Side effects:
+ * None.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+char *
+TclWinNoBackslash(
+ char *path) /* String to change. */
+{
+ char *p;
+
+ for (p = path; *p != '\0'; p++) {
+ if (*p == '\\') {
+ *p = '/';
+ }
+ }
+ return path;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpCheckStackSpace --
+ *
+ * Detect if we are about to blow the stack. Called before an
+ * evaluation can happen when nesting depth is checked.
+ *
+ * Results:
+ * 1 if there is enough stack space to continue; 0 if not.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclpCheckStackSpace()
+{
+ /*
+ * We can recurse only if there is at least TCL_WIN_STACK_THRESHOLD
+ * bytes of stack space left. alloca() is cheap on windows; basically
+ * it just subtracts from the stack pointer causing the OS to throw an
+ * exception if the stack pointer is set below the bottom of the stack.
+ */
+
+ try {
+ alloca(TCL_WIN_STACK_THRESHOLD);
+ return 1;
+ } except (1) {}
+
+ return 0;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclWinGetPlatform --
+ *
+ * This is a kludge that allows the test library to get access
+ * the internal tclPlatform variable.
+ *
+ * Results:
+ * Returns a pointer to the tclPlatform variable.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+TclPlatformType *
+TclWinGetPlatform()
+{
+ return &tclPlatform;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclWinSetInterfaces --
+ *
+ * A helper proc that allows the test library to change the
+ * tclWinProcs structure to dispatch to either the wide-character
+ * or multi-byte versions of the operating system calls, depending
+ * on whether Unicode is the system encoding.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+void
+TclWinSetInterfaces(
+ int wide) /* Non-zero to use wide interfaces, 0
+ * otherwise. */
+{
+ Tcl_FreeEncoding(tclWinTCharEncoding);
+
+ if (wide) {
+ tclWinProcs = &unicodeProcs;
+ tclWinTCharEncoding = Tcl_GetEncoding(NULL, "unicode");
+ } else {
+ tclWinProcs = &asciiProcs;
+ tclWinTCharEncoding = NULL;
+ }
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_WinUtfToTChar, Tcl_WinTCharToUtf --
+ *
+ * Convert between UTF-8 and Unicode when running Windows NT or
+ * the current ANSI code page when running Windows 95.
+ *
+ * On Mac, Unix, and Windows 95, all strings exchanged between Tcl
+ * and the OS are "char" oriented. We need only one Tcl_Encoding to
+ * convert between UTF-8 and the system's native encoding. We use
+ * NULL to represent that encoding.
+ *
+ * On NT, some strings exchanged between Tcl and the OS are "char"
+ * oriented, while others are in Unicode. We need two Tcl_Encodings
+ * depending on whether we are targeting a "char" or Unicode
+ * interface.
+ *
+ * Calling Tcl_UtfToExternal() or Tcl_ExternalToUtf() with an
+ * encoding of NULL should always used to convert between UTF-8
+ * and the system's "char" oriented encoding. The following two
+ * functions are used in Windows-specific code to convert between
+ * UTF-8 and Unicode strings (NT) or "char" strings(95). This saves
+ * you the trouble of writing the following type of fragment over and
+ * over:
+ *
+ * if (running NT) {
+ * encoding <- Tcl_GetEncoding("unicode");
+ * nativeBuffer <- UtfToExternal(encoding, utfBuffer);
+ * Tcl_FreeEncoding(encoding);
+ * } else {
+ * nativeBuffer <- UtfToExternal(NULL, utfBuffer);
+ * }
+ *
+ * By convention, in Windows a TCHAR is a character in the ANSI code
+ * page on Windows 95, a Unicode character on Windows NT. If you
+ * plan on targeting a Unicode interfaces when running on NT and a
+ * "char" oriented interface while running on 95, these functions
+ * should be used. If you plan on targetting the same "char"
+ * oriented function on both 95 and NT, use Tcl_UtfToExternal()
+ * with an encoding of NULL.
+ *
+ * Results:
+ * The result is a pointer to the string in the desired target
+ * encoding. Storage for the result string is allocated in
+ * dsPtr; the caller must call Tcl_DStringFree() when the result
+ * is no longer needed.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+TCHAR *
+Tcl_WinUtfToTChar(string, len, dsPtr)
+ CONST char *string; /* Source string in UTF-8. */
+ int len; /* Source string length in bytes, or < 0 for
+ * strlen(). */
+ Tcl_DString *dsPtr; /* Uninitialized or free DString in which
+ * the converted string is stored. */
+{
+ return (TCHAR *) Tcl_UtfToExternalDString(tclWinTCharEncoding,
+ string, len, dsPtr);
+}
+
+char *
+Tcl_WinTCharToUtf(string, len, dsPtr)
+ CONST TCHAR *string; /* Source string in Unicode when running
+ * NT, ANSI when running 95. */
+ int len; /* Source string length in bytes, or < 0 for
+ * platform-specific string length. */
+ Tcl_DString *dsPtr; /* Uninitialized or free DString in which
+ * the converted string is stored. */
+{
+ return Tcl_ExternalToUtfDString(tclWinTCharEncoding,
+ (CONST char *) string, len, dsPtr);
}
diff --git a/win/tclWinChan.c b/win/tclWinChan.c
index 248e14b..913d547 100644
--- a/win/tclWinChan.c
+++ b/win/tclWinChan.c
@@ -9,26 +9,12 @@
* 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
+ * SCCS: @(#) tclWinChan.c 1.83 98/02/19 14:12:21
*/
#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.
*/
@@ -53,11 +39,15 @@ typedef struct FileInfo {
struct FileInfo *nextPtr; /* Pointer to next registered file. */
} FileInfo;
-/*
- * List of all file channels currently open.
- */
+typedef struct ThreadSpecificData {
+ /*
+ * List of all file channels currently open.
+ */
-static FileInfo *firstFilePtr;
+ FileInfo *firstFilePtr;
+} ThreadSpecificData;
+
+static Tcl_ThreadDataKey dataKey;
/*
* The following structure is what is added to the Tcl event queue when
@@ -97,7 +87,7 @@ 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 ThreadSpecificData *FileInit _ANSI_ARGS_((void));
static int FileInputProc _ANSI_ARGS_((ClientData instanceData,
char *buf, int toRead, int *errorCode));
static int FileOutputProc _ANSI_ARGS_((ClientData instanceData,
@@ -156,13 +146,18 @@ static Tcl_ChannelType comChannelType = {
*----------------------------------------------------------------------
*/
-static void
+static ThreadSpecificData *
FileInit()
{
- initialized = 1;
- firstFilePtr = NULL;
- Tcl_CreateEventSource(FileSetupProc, FileCheckProc, NULL);
- Tcl_CreateExitHandler(FileChannelExitHandler, NULL);
+ ThreadSpecificData *tsdPtr =
+ (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
+ if (tsdPtr == NULL) {
+ tsdPtr = TCL_TSD_INIT(&dataKey);
+ tsdPtr->firstFilePtr = NULL;
+ Tcl_CreateEventSource(FileSetupProc, FileCheckProc, NULL);
+ Tcl_CreateThreadExitHandler(FileChannelExitHandler, NULL);
+ }
+ return tsdPtr;
}
/*
@@ -187,7 +182,6 @@ FileChannelExitHandler(clientData)
ClientData clientData; /* Old window proc */
{
Tcl_DeleteEventSource(FileSetupProc, FileCheckProc, NULL);
- initialized = 0;
}
/*
@@ -214,6 +208,7 @@ FileSetupProc(data, flags)
{
FileInfo *infoPtr;
Tcl_Time blockTime = { 0, 0 };
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!(flags & TCL_FILE_EVENTS)) {
return;
@@ -223,7 +218,8 @@ FileSetupProc(data, flags)
* Check to see if there is a ready file. If so, poll.
*/
- for (infoPtr = firstFilePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
+ for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
+ infoPtr = infoPtr->nextPtr) {
if (infoPtr->watchMask) {
Tcl_SetMaxBlockTime(&blockTime);
break;
@@ -255,6 +251,7 @@ FileCheckProc(data, flags)
{
FileEvent *evPtr;
FileInfo *infoPtr;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!(flags & TCL_FILE_EVENTS)) {
return;
@@ -266,7 +263,8 @@ FileCheckProc(data, flags)
* events).
*/
- for (infoPtr = firstFilePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
+ for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
+ infoPtr = infoPtr->nextPtr) {
if (infoPtr->watchMask && !(infoPtr->flags & FILE_PENDING)) {
infoPtr->flags |= FILE_PENDING;
evPtr = (FileEvent *) ckalloc(sizeof(FileEvent));
@@ -305,6 +303,7 @@ FileEventProc(evPtr, flags)
{
FileEvent *fileEvPtr = (FileEvent *)evPtr;
FileInfo *infoPtr;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!(flags & TCL_FILE_EVENTS)) {
return 0;
@@ -317,7 +316,8 @@ FileEventProc(evPtr, flags)
* event is in the queue.
*/
- for (infoPtr = firstFilePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
+ for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
+ infoPtr = infoPtr->nextPtr) {
if (fileEvPtr->infoPtr == infoPtr) {
infoPtr->flags &= ~(FILE_PENDING);
Tcl_NotifyChannel(infoPtr->channel, infoPtr->watchMask);
@@ -390,6 +390,7 @@ FileCloseProc(instanceData, interp)
FileInfo *fileInfoPtr = (FileInfo *) instanceData;
FileInfo **nextPtrPtr;
int errorCode = 0;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* Remove the file from the watch list.
@@ -397,11 +398,16 @@ FileCloseProc(instanceData, interp)
FileWatchProc(instanceData, 0);
- if (CloseHandle(fileInfoPtr->handle) == FALSE) {
- TclWinConvertError(GetLastError());
- errorCode = errno;
+ if (!TclInExit()
+ || ((GetStdHandle(STD_INPUT_HANDLE) != fileInfoPtr->handle)
+ && (GetStdHandle(STD_OUTPUT_HANDLE) != fileInfoPtr->handle)
+ && (GetStdHandle(STD_ERROR_HANDLE) != fileInfoPtr->handle))) {
+ if (CloseHandle(fileInfoPtr->handle) == FALSE) {
+ TclWinConvertError(GetLastError());
+ errorCode = errno;
+ }
}
- for (nextPtrPtr = &firstFilePtr; (*nextPtrPtr) != NULL;
+ for (nextPtrPtr = &(tsdPtr->firstFilePtr); (*nextPtrPtr) != NULL;
nextPtrPtr = &((*nextPtrPtr)->nextPtr)) {
if ((*nextPtrPtr) == fileInfoPtr) {
(*nextPtrPtr) = fileInfoPtr->nextPtr;
@@ -704,7 +710,7 @@ ComInputProc(instanceData, buf, bufSize, errorCode)
* Sets an option on a channel.
*
* Results:
- * A standard Tcl result. Also sets interp->result on error if
+ * A standard Tcl result. Also sets the interp's result on error if
* interp is not NULL.
*
* Side effects:
@@ -723,17 +729,25 @@ ComSetOptionProc(instanceData, interp, optionName, value)
FileInfo *infoPtr;
DCB dcb;
int len;
+ BOOL result;
+ Tcl_DString ds;
+ TCHAR *native;
infoPtr = (FileInfo *) instanceData;
len = strlen(optionName);
if ((len > 1) && (strncmp(optionName, "-mode", len) == 0)) {
if (GetCommState(infoPtr->handle, &dcb)) {
- if ((BuildCommDCB(value, &dcb) == FALSE) ||
+ native = Tcl_WinUtfToTChar(value, -1, &ds);
+ result = (*tclWinProcs->buildCommDCBProc)(native, &dcb);
+ Tcl_DStringFree(&ds);
+
+ if ((result == FALSE) ||
(SetCommState(infoPtr->handle, &dcb) == FALSE)) {
/*
* one should separate the 2 errors...
*/
+
if (interp) {
Tcl_AppendResult(interp, "bad value for -mode: should be ",
"baud,parity,data,stop", NULL);
@@ -803,7 +817,7 @@ ComGetOptionProc(instanceData, interp, optionName, dsPtr)
} else {
char parity;
char *stop;
- char buf[32];
+ char buf[2 * TCL_INTEGER_SPACE + 16];
parity = 'n';
if (dcb.Parity < 4) {
@@ -813,7 +827,7 @@ ComGetOptionProc(instanceData, interp, optionName, dsPtr)
stop = (dcb.StopBits == ONESTOPBIT) ? "1" :
(dcb.StopBits == ONE5STOPBITS) ? "1.5" : "2";
- wsprintf(buf, "%d,%c,%d,%s", dcb.BaudRate, parity, dcb.ByteSize,
+ wsprintfA(buf, "%d,%c,%d,%s", dcb.BaudRate, parity, dcb.ByteSize,
stop);
Tcl_DStringAppendElement(dsPtr, buf);
}
@@ -855,25 +869,27 @@ Tcl_OpenFileChannel(interp, fileName, modeString, permissions)
FileInfo *infoPtr;
int seekFlag, mode, channelPermissions;
DWORD accessMode, createMode, shareMode, flags;
- char *nativeName;
- Tcl_DString buffer;
+ TCHAR *nativeName;
+ Tcl_DString ds, buffer;
DCB dcb;
Tcl_ChannelType *channelTypePtr;
HANDLE handle;
+ char channelName[16 + TCL_INTEGER_SPACE];
+ ThreadSpecificData *tsdPtr;
- if (!initialized) {
- FileInit();
- }
+ tsdPtr = FileInit();
mode = TclGetOpenMode(interp, modeString, &seekFlag);
if (mode == -1) {
return NULL;
}
- nativeName = Tcl_TranslateFileName(interp, fileName, &buffer);
- if (nativeName == NULL) {
+ if (Tcl_TranslateFileName(interp, fileName, &ds) == NULL) {
return NULL;
}
+ nativeName = Tcl_WinUtfToTChar(Tcl_DStringValue(&ds),
+ Tcl_DStringLength(&ds), &buffer);
+ Tcl_DStringFree(&ds);
switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
case O_RDONLY:
@@ -929,7 +945,7 @@ Tcl_OpenFileChannel(interp, fileName, modeString, permissions)
flags = FILE_ATTRIBUTE_READONLY;
}
} else {
- flags = GetFileAttributes(nativeName);
+ flags = (*tclWinProcs->getFileAttributesProc)(nativeName);
if (flags == 0xFFFFFFFF) {
flags = 0;
}
@@ -945,8 +961,8 @@ Tcl_OpenFileChannel(interp, fileName, modeString, permissions)
* Now we get to create the file.
*/
- handle = CreateFile(nativeName, accessMode, shareMode, NULL, createMode,
- flags, (HANDLE) NULL);
+ handle = (*tclWinProcs->createFileProc)(nativeName, accessMode,
+ shareMode, NULL, createMode, flags, (HANDLE) NULL);
if (handle == INVALID_HANDLE_VALUE) {
DWORD err;
@@ -965,6 +981,7 @@ Tcl_OpenFileChannel(interp, fileName, modeString, permissions)
return NULL;
}
+ channelTypePtr = &fileChannelType;
if (GetFileType(handle) == FILE_TYPE_CHAR) {
dcb.DCBlength = sizeof( DCB ) ;
if (GetCommState(handle, &dcb)) {
@@ -975,8 +992,8 @@ Tcl_OpenFileChannel(interp, fileName, modeString, permissions)
COMMTIMEOUTS cto;
CloseHandle(handle);
- handle = CreateFile(nativeName, accessMode, 0, NULL, OPEN_EXISTING,
- flags, NULL);
+ handle = (*tclWinProcs->createFileProc)(nativeName, accessMode,
+ 0, NULL, OPEN_EXISTING, flags, NULL);
if (handle == INVALID_HANDLE_VALUE) {
goto openerr;
}
@@ -999,23 +1016,19 @@ Tcl_OpenFileChannel(interp, fileName, modeString, permissions)
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->nextPtr = tsdPtr->firstFilePtr;
+ tsdPtr->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);
+ wsprintfA(channelName, "file%d", (int) handle);
infoPtr->channel = Tcl_CreateChannel(channelTypePtr, channelName,
(ClientData) infoPtr, channelPermissions);
@@ -1034,7 +1047,7 @@ Tcl_OpenFileChannel(interp, fileName, modeString, permissions)
/*
* Files have default translation of AUTO and ^Z eof char, which
- * means that a ^Z will be appended to them at close.
+ * means that a ^Z will be accepted as EOF when reading.
*/
Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
@@ -1065,32 +1078,32 @@ Tcl_MakeFileChannel(handle, mode)
int mode; /* ORed combination of TCL_READABLE and
* TCL_WRITABLE to indicate file mode. */
{
- char channelName[20];
+ char channelName[16 + TCL_INTEGER_SPACE];
FileInfo *infoPtr;
+ ThreadSpecificData *tsdPtr;
- if (!initialized) {
- FileInit();
- }
+ tsdPtr = FileInit();
if (mode == 0) {
return NULL;
}
- sprintf(channelName, "file%d", (int) handle);
+ wsprintfA(channelName, "file%d", (int) handle);
/*
* See if a channel with this handle already exists.
*/
- for (infoPtr = firstFilePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
+ for (infoPtr = tsdPtr->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->nextPtr = tsdPtr->firstFilePtr;
+ tsdPtr->firstFilePtr = infoPtr;
infoPtr->validMask = mode;
infoPtr->watchMask = 0;
infoPtr->flags = 0;
@@ -1110,7 +1123,7 @@ Tcl_MakeFileChannel(handle, mode)
/*
*----------------------------------------------------------------------
*
- * TclGetDefaultStdChannel --
+ * TclpGetDefaultStdChannel --
*
* Constructs a channel for the specified standard OS handle.
*
@@ -1125,7 +1138,7 @@ Tcl_MakeFileChannel(handle, mode)
*/
Tcl_Channel
-TclGetDefaultStdChannel(type)
+TclpGetDefaultStdChannel(type)
int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */
{
Tcl_Channel channel;
diff --git a/win/tclWinError.c b/win/tclWinError.c
index 5361174..8e67b34 100644
--- a/win/tclWinError.c
+++ b/win/tclWinError.c
@@ -9,11 +9,10 @@
* 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
+ * SCCS: @(#) tclWinError.c 1.8 97/10/29 09:47:13
*/
-#include "tclInt.h"
-#include "tclPort.h"
+#include "tclWinInt.h"
/*
* The following table contains the mapping from Win32 errors to
diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c
index f2df779..97986c9 100644
--- a/win/tclWinFCmd.c
+++ b/win/tclWinFCmd.c
@@ -4,12 +4,12 @@
* This file implements the Windows specific portion of file manipulation
* subcommands of the "file" command.
*
- * Copyright (c) 1996-1997 Sun Microsystems, Inc.
+ * Copyright (c) 1996-1998 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclWinFCmd.c 1.20 97/10/10 11:50:14
+ * SCCS: @(#) tclWinFCmd.c 1.34 98/02/11 17:39:47
*/
#include "tclWinInt.h"
@@ -28,19 +28,19 @@
*/
static int GetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp,
- int objIndex, char *fileName,
+ int objIndex, CONST char *fileName,
Tcl_Obj **attributePtrPtr));
static int GetWinFileLongName _ANSI_ARGS_((Tcl_Interp *interp,
- int objIndex, char *fileName,
+ int objIndex, CONST char *fileName,
Tcl_Obj **attributePtrPtr));
static int GetWinFileShortName _ANSI_ARGS_((Tcl_Interp *interp,
- int objIndex, char *fileName,
+ int objIndex, CONST char *fileName,
Tcl_Obj **attributePtrPtr));
static int SetWinFileAttributes _ANSI_ARGS_((Tcl_Interp *interp,
- int objIndex, char *fileName,
+ int objIndex, CONST char *fileName,
Tcl_Obj *attributePtr));
static int CannotSetAttribute _ANSI_ARGS_((Tcl_Interp *interp,
- int objIndex, char *fileName,
+ int objIndex, CONST char *fileName,
Tcl_Obj *attributePtr));
/*
@@ -60,9 +60,12 @@ 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[] = {
+char *tclpFileAttrStrings[] = {
+ "-archive", "-hidden", "-longname", "-readonly",
+ "-shortname", "-system", (char *) NULL
+};
+
+const TclFileAttrProcs tclpFileAttrProcs[] = {
{GetWinFileAttributes, SetWinFileAttributes},
{GetWinFileAttributes, SetWinFileAttributes},
{GetWinFileLongName, CannotSetAttribute},
@@ -74,31 +77,36 @@ CONST TclFileAttrProcs tclpFileAttrProcs[] = {
* Prototype for the TraverseWinTree callback function.
*/
-typedef int (TraversalProc)(char *src, char *dst, DWORD attr, int type,
- Tcl_DString *errorPtr);
+typedef int (TraversalProc)(Tcl_DString *srcPtr, Tcl_DString *dstPtr,
+ 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 void StatError(Tcl_Interp *interp, CONST char *fileName);
+static int ConvertFileNameFormat(Tcl_Interp *interp,
+ int objIndex, CONST char *fileName, int longShort,
+ Tcl_Obj **attributePtrPtr);
+static int DoCopyFile(Tcl_DString *srcPtr, Tcl_DString *dstPtr);
+static int DoCreateDirectory(Tcl_DString *pathPtr);
+static int DoDeleteFile(Tcl_DString *pathPtr);
+static int DoRemoveDirectory(Tcl_DString *pathPtr, int recursive,
+ Tcl_DString *errorPtr);
+static int DoRenameFile(const TCHAR *nativeSrc, Tcl_DString *dstPtr);
+static int TraversalCopy(Tcl_DString *srcPtr, Tcl_DString *dstPtr,
+ int type, Tcl_DString *errorPtr);
+static int TraversalDelete(Tcl_DString *srcPtr, Tcl_DString *dstPtr,
+ int type, Tcl_DString *errorPtr);
static int TraverseWinTree(TraversalProc *traverseProc,
- Tcl_DString *sourcePtr, Tcl_DString *destPtr,
+ Tcl_DString *sourcePtr, Tcl_DString *dstPtr,
Tcl_DString *errorPtr);
/*
*---------------------------------------------------------------------------
*
- * TclpRenameFile --
+ * TclpRenameFile, DoRenameFile --
*
* Changes the name of an existing file or directory, from src to dst.
* If src and dst refer to the same file or directory, does nothing
@@ -110,10 +118,11 @@ static int TraverseWinTree(TraversalProc *traverseProc,
* fail.
*
* Results:
- * If the directory was successfully created, returns TCL_OK.
+ * If the file or directory was successfully renamed, returns TCL_OK.
* Otherwise the return value is TCL_ERROR and errno is set to
* indicate the error. Some possible values for errno are:
*
+ * ENAMETOOLONG: src or dst names are too long.
* EACCES: src or dst parent directory can't be read and/or written.
* EEXIST: dst is a non-empty directory.
* EINVAL: src is a root directory or dst is a subdirectory of src.
@@ -138,30 +147,76 @@ static int TraverseWinTree(TraversalProc *traverseProc,
int
TclpRenameFile(
- char *src, /* Pathname of file or dir to be renamed. */
- char *dst) /* New pathname for file or directory. */
+ CONST char *src, /* Pathname of file or dir to be renamed
+ * (UTF-8). */
+ CONST char *dst) /* New pathname of file or directory
+ * (UTF-8). */
{
+ int result;
+ TCHAR *nativeSrc;
+ Tcl_DString srcString, dstString;
+
+ nativeSrc = Tcl_WinUtfToTChar(src, -1, &srcString);
+ Tcl_WinUtfToTChar(dst, -1, &dstString);
+
+ if ((TclWinGetPlatformId() == VER_PLATFORM_WIN32s)
+ && ((Tcl_DStringLength(&srcString) >= MAX_PATH - 1) ||
+ (Tcl_DStringLength(&dstString) >= MAX_PATH - 1))) {
+ /*
+ * On Win32s, really long file names cause the MoveFile() call
+ * to lock up, endlessly throwing an access violation and
+ * retrying the operation.
+ */
+
+ errno = ENAMETOOLONG;
+ result = TCL_ERROR;
+ } else {
+ result = DoRenameFile(nativeSrc, &dstString);
+ }
+ Tcl_DStringFree(&srcString);
+ Tcl_DStringFree(&dstString);
+ return result;
+}
+
+static int
+DoRenameFile(
+ CONST TCHAR *nativeSrc, /* Pathname of file or dir to be renamed
+ * (native). */
+ Tcl_DString *dstPtr) /* New pathname for file or directory
+ * (native). */
+{
+ const TCHAR *nativeDst;
DWORD srcAttr, dstAttr;
-
+
+ nativeDst = (TCHAR *) Tcl_DStringValue(dstPtr);
+
/*
* Would throw an exception under NT if one of the arguments is a
* char block device.
*/
try {
- if (MoveFile(src, dst) != FALSE) {
+ if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) {
return TCL_OK;
}
} except (-1) {}
TclWinConvertError(GetLastError());
- srcAttr = GetFileAttributes(src);
- dstAttr = GetFileAttributes(dst);
- if (srcAttr == (DWORD) -1) {
+ srcAttr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
+ dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst);
+ if (srcAttr == 0xffffffff) {
+ if ((*tclWinProcs->getFullPathNameProc)(nativeSrc, 0, NULL, NULL) >= MAX_PATH) {
+ errno = ENAMETOOLONG;
+ return TCL_ERROR;
+ }
srcAttr = 0;
}
- if (dstAttr == (DWORD) -1) {
+ if (dstAttr == 0xffffffff) {
+ if ((*tclWinProcs->getFullPathNameProc)(nativeDst, 0, NULL, NULL) >= MAX_PATH) {
+ errno = ENAMETOOLONG;
+ return TCL_ERROR;
+ }
dstAttr = 0;
}
@@ -169,7 +224,7 @@ TclpRenameFile(
errno = EACCES;
return TCL_ERROR;
}
- if ((errno == EACCES) && (TclWinGetPlatformId() == VER_PLATFORM_WIN32s)) {
+ if ((TclWinGetPlatformId() == VER_PLATFORM_WIN32s) && (errno == EACCES)) {
if ((srcAttr != 0) && (dstAttr != 0)) {
/*
* Win32s reports trying to overwrite an existing file or directory
@@ -182,33 +237,44 @@ TclpRenameFile(
if (errno == EACCES) {
decode:
if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) {
- char srcPath[MAX_PATH], dstPath[MAX_PATH];
- int srcArgc, dstArgc;
+ TCHAR *nativeSrcRest, *nativeDstRest;
char **srcArgv, **dstArgv;
- char *srcRest, *dstRest;
- int size;
-
- size = GetFullPathName(src, sizeof(srcPath), srcPath, &srcRest);
- if ((size == 0) || (size > sizeof(srcPath))) {
+ int size, srcArgc, dstArgc;
+ WCHAR nativeSrcPath[MAX_PATH];
+ WCHAR nativeDstPath[MAX_PATH];
+ Tcl_DString srcString, dstString;
+ CONST char *src, *dst;
+
+ size = (*tclWinProcs->getFullPathNameProc)(nativeSrc, MAX_PATH,
+ nativeSrcPath, &nativeSrcRest);
+ if ((size == 0) || (size > MAX_PATH)) {
return TCL_ERROR;
}
- size = GetFullPathName(dst, sizeof(dstPath), dstPath, &dstRest);
- if ((size == 0) || (size > sizeof(dstPath))) {
+ size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH,
+ nativeDstPath, &nativeDstRest);
+ if ((size == 0) || (size > MAX_PATH)) {
return TCL_ERROR;
}
- if (srcRest == NULL) {
- srcRest = srcPath + strlen(srcPath);
- }
- if (strnicmp(srcPath, dstPath, srcRest - srcPath) == 0) {
+ (*tclWinProcs->charLowerProc)((TCHAR *) nativeSrcPath);
+ (*tclWinProcs->charLowerProc)((TCHAR *) nativeDstPath);
+
+ src = Tcl_WinTCharToUtf((TCHAR *) nativeSrcPath, -1, &srcString);
+ dst = Tcl_WinTCharToUtf((TCHAR *) nativeDstPath, -1, &dstString);
+ if (strncmp(src, dst, Tcl_DStringLength(&srcString)) == 0) {
/*
* Trying to move a directory into itself.
*/
errno = EINVAL;
+ Tcl_DStringFree(&srcString);
+ Tcl_DStringFree(&dstString);
return TCL_ERROR;
}
- Tcl_SplitPath(srcPath, &srcArgc, &srcArgv);
- Tcl_SplitPath(dstPath, &dstArgc, &dstArgv);
+ Tcl_SplitPath(src, &srcArgc, &srcArgv);
+ Tcl_SplitPath(dst, &dstArgc, &dstArgv);
+ Tcl_DStringFree(&srcString);
+ Tcl_DStringFree(&dstString);
+
if (srcArgc == 1) {
/*
* They are trying to move a root directory. Whether
@@ -216,9 +282,9 @@ TclpRenameFile(
* done.
*/
- errno = EINVAL;
+ Tcl_SetErrno(EINVAL);
} else if ((srcArgc > 0) && (dstArgc > 0) &&
- (stricmp(srcArgv[0], dstArgv[0]) != 0)) {
+ (strcmp(srcArgv[0], dstArgv[0]) != 0)) {
/*
* If src is a directory and dst filesystem != src
* filesystem, errno should be EXDEV. It is very
@@ -229,7 +295,7 @@ TclpRenameFile(
* file between filesystems.
*/
- errno = EXDEV;
+ Tcl_SetErrno(EXDEV);
}
ckfree((char *) srcArgv);
@@ -243,7 +309,7 @@ TclpRenameFile(
* current filesystem. EACCES is returned for those cases.
*/
- } else if (errno == EEXIST) {
+ } else if (Tcl_GetErrno() == EEXIST) {
/*
* Reports EEXIST any time the target already exists. If it makes
* sense, remove the old file and try renaming again.
@@ -257,14 +323,14 @@ TclpRenameFile(
* fails, it's because it wasn't empty.
*/
- if (TclpRemoveDirectory(dst, 0, NULL) == TCL_OK) {
+ if (DoRemoveDirectory(dstPtr, 0, NULL) == TCL_OK) {
/*
* Now that that empty directory is gone, we can try
* renaming again. If that fails, we'll put this empty
* directory back, for completeness.
*/
- if (MoveFile(src, dst) != FALSE) {
+ if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) {
return TCL_OK;
}
@@ -274,9 +340,9 @@ TclpRenameFile(
*/
TclWinConvertError(GetLastError());
- CreateDirectory(dst, NULL);
- SetFileAttributes(dst, dstAttr);
- if (errno == EACCES) {
+ (*tclWinProcs->createDirectoryProc)(nativeDst, NULL);
+ (*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr);
+ if (Tcl_GetErrno() == EACCES) {
/*
* Decode the EACCES to a more meaningful error.
*/
@@ -285,11 +351,11 @@ TclpRenameFile(
}
}
} else { /* (dstAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */
- errno = ENOTDIR;
+ Tcl_SetErrno(ENOTDIR);
}
} else { /* (srcAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */
if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) {
- errno = EISDIR;
+ Tcl_SetErrno(EISDIR);
} else {
/*
* Overwrite existing file by:
@@ -300,17 +366,24 @@ TclpRenameFile(
* put temp file back to old name.
*/
- char tempName[MAX_PATH];
+ TCHAR *nativeRest, *nativeTmp, *nativePrefix;
int result, size;
- char *rest;
+ WCHAR tempBuf[MAX_PATH];
- size = GetFullPathName(dst, sizeof(tempName), tempName, &rest);
- if ((size == 0) || (size > sizeof(tempName)) || (rest == NULL)) {
+ size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH,
+ tempBuf, &nativeRest);
+ if ((size == 0) || (size > MAX_PATH) || (nativeRest == NULL)) {
return TCL_ERROR;
}
- *rest = '\0';
+ nativeTmp = (TCHAR *) tempBuf;
+ ((char *) nativeRest)[0] = '\0';
+ ((char *) nativeRest)[1] = '\0'; /* In case it's Unicode. */
+
result = TCL_ERROR;
- if (GetTempFileName(tempName, "tclr", 0, tempName) != 0) {
+ nativePrefix = (tclWinProcs->useWide)
+ ? (TCHAR *) L"tclr" : (TCHAR *) "tclr";
+ if ((*tclWinProcs->getTempFileNameProc)(nativeTmp,
+ nativePrefix, 0, tempBuf) != 0) {
/*
* Strictly speaking, need the following DeleteFile and
* MoveFile to be joined as an atomic operation so no
@@ -318,15 +391,17 @@ TclpRenameFile(
* same temp file.
*/
- DeleteFile(tempName);
- if (MoveFile(dst, tempName) != FALSE) {
- if (MoveFile(src, dst) != FALSE) {
- SetFileAttributes(tempName, FILE_ATTRIBUTE_NORMAL);
- DeleteFile(tempName);
+ nativeTmp = (TCHAR *) tempBuf;
+ (*tclWinProcs->deleteFileProc)(nativeTmp);
+ if ((*tclWinProcs->moveFileProc)(nativeDst, nativeTmp) != FALSE) {
+ if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) {
+ (*tclWinProcs->setFileAttributesProc)(nativeTmp,
+ FILE_ATTRIBUTE_NORMAL);
+ (*tclWinProcs->deleteFileProc)(nativeTmp);
return TCL_OK;
} else {
- DeleteFile(dst);
- MoveFile(tempName, dst);
+ (*tclWinProcs->deleteFileProc)(nativeDst);
+ (*tclWinProcs->moveFileProc)(nativeTmp, nativeDst);
}
}
@@ -336,7 +411,7 @@ TclpRenameFile(
*/
TclWinConvertError(GetLastError());
- if (errno == EACCES) {
+ if (Tcl_GetErrno() == EACCES) {
/*
* Decode the EACCES to a more meaningful error.
*/
@@ -354,7 +429,7 @@ TclpRenameFile(
/*
*---------------------------------------------------------------------------
*
- * TclpCopyFile --
+ * TclpCopyFile, DoCopyFile --
*
* Copy a single file (not a directory). If dst already exists and
* is not a directory, it is removed.
@@ -380,41 +455,63 @@ TclpRenameFile(
int
TclpCopyFile(
- char *src, /* Pathname of file to be copied. */
- char *dst) /* Pathname of file to copy to. */
+ CONST char *src, /* Pathname of file to be copied (UTF-8). */
+ CONST char *dst) /* Pathname of file to copy to (UTF-8). */
+{
+ int result;
+ Tcl_DString srcString, dstString;
+
+ Tcl_WinUtfToTChar(src, -1, &srcString);
+ Tcl_WinUtfToTChar(dst, -1, &dstString);
+ result = DoCopyFile(&srcString, &dstString);
+ Tcl_DStringFree(&srcString);
+ Tcl_DStringFree(&dstString);
+ return result;
+}
+
+static int
+DoCopyFile(
+ Tcl_DString *srcPtr, /* Pathname of file to be copied (native). */
+ Tcl_DString *dstPtr) /* Pathname of file to copy to (native). */
{
+ CONST TCHAR *nativeSrc, *nativeDst;
+
+ nativeSrc = (TCHAR *) Tcl_DStringValue(srcPtr);
+ nativeDst = (TCHAR *) Tcl_DStringValue(dstPtr);
+
/*
* Would throw an exception under NT if one of the arguments is a char
* block device.
*/
try {
- if (CopyFile(src, dst, 0) != FALSE) {
+ if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) {
return TCL_OK;
}
} except (-1) {}
TclWinConvertError(GetLastError());
- if (errno == EBADF) {
- errno = EACCES;
+ if (Tcl_GetErrno() == EBADF) {
+ Tcl_SetErrno(EACCES);
return TCL_ERROR;
}
- if (errno == EACCES) {
+ if (Tcl_GetErrno() == EACCES) {
DWORD srcAttr, dstAttr;
- srcAttr = GetFileAttributes(src);
- dstAttr = GetFileAttributes(dst);
- if (srcAttr != (DWORD) -1) {
- if (dstAttr == (DWORD) -1) {
+ srcAttr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
+ dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst);
+ if (srcAttr != 0xffffffff) {
+ if (dstAttr == 0xffffffff) {
dstAttr = 0;
}
if ((srcAttr & FILE_ATTRIBUTE_DIRECTORY) ||
(dstAttr & FILE_ATTRIBUTE_DIRECTORY)) {
- errno = EISDIR;
+ Tcl_SetErrno(EISDIR);
}
if (dstAttr & FILE_ATTRIBUTE_READONLY) {
- SetFileAttributes(dst, dstAttr & ~FILE_ATTRIBUTE_READONLY);
- if (CopyFile(src, dst, 0) != FALSE) {
+ (*tclWinProcs->setFileAttributesProc)(nativeDst,
+ dstAttr & ~FILE_ATTRIBUTE_READONLY);
+ if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) {
return TCL_OK;
}
/*
@@ -423,7 +520,7 @@ TclpCopyFile(
*/
TclWinConvertError(GetLastError());
- SetFileAttributes(dst, dstAttr);
+ (*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr);
}
}
}
@@ -433,7 +530,7 @@ TclpCopyFile(
/*
*---------------------------------------------------------------------------
*
- * TclpDeleteFile --
+ * TclpDeleteFile, DoDeleteFile --
*
* Removes a single file (not a directory).
*
@@ -457,59 +554,86 @@ TclpCopyFile(
int
TclpDeleteFile(
- char *path) /* Pathname of file to be removed. */
+ CONST char *path) /* Pathname of file to be removed (UTF-8). */
+{
+ int result;
+ Tcl_DString pathString;
+
+ Tcl_WinUtfToTChar(path, -1, &pathString);
+ result = DoDeleteFile(&pathString);
+ Tcl_DStringFree(&pathString);
+ return result;
+}
+
+static int
+DoDeleteFile(
+ Tcl_DString *pathPtr) /* Pathname of file to be removed (native). */
{
DWORD attr;
+ CONST TCHAR *nativePath;
- if (DeleteFile(path) != FALSE) {
+ nativePath = (TCHAR *) Tcl_DStringValue(pathPtr);
+
+ if ((*tclWinProcs->deleteFileProc)(nativePath) != 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) {
+ /*
+ * Win32s thinks that "" is the same as "." and then reports EISDIR
+ * instead of ENOENT.
+ */
+
+ if (tclWinProcs->useWide) {
+ if (((WCHAR *) nativePath)[0] == '\0') {
+ Tcl_SetErrno(ENOENT);
+ return TCL_ERROR;
+ }
+ } else {
+ if (((char *) nativePath)[0] == '\0') {
+ Tcl_SetErrno(ENOENT);
+ return TCL_ERROR;
+ }
+ }
+ if (Tcl_GetErrno() == EACCES) {
+ attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
+ if (attr != 0xffffffff) {
if (attr & FILE_ATTRIBUTE_DIRECTORY) {
/*
* Windows NT reports removing a directory as EACCES instead
* of EISDIR.
*/
- errno = EISDIR;
+ Tcl_SetErrno(EISDIR);
} else if (attr & FILE_ATTRIBUTE_READONLY) {
- SetFileAttributes(path, attr & ~FILE_ATTRIBUTE_READONLY);
- if (DeleteFile(path) != FALSE) {
+ (*tclWinProcs->setFileAttributesProc)(nativePath,
+ attr & ~FILE_ATTRIBUTE_READONLY);
+ if ((*tclWinProcs->deleteFileProc)(nativePath) != FALSE) {
return TCL_OK;
}
TclWinConvertError(GetLastError());
- SetFileAttributes(path, attr);
+ (*tclWinProcs->setFileAttributesProc)(nativePath, attr);
}
}
- } else if (errno == ENOENT) {
- attr = GetFileAttributes(path);
- if (attr != (DWORD) -1) {
+ } else if (Tcl_GetErrno() == ENOENT) {
+ attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
+ if (attr != 0xffffffff) {
if (attr & FILE_ATTRIBUTE_DIRECTORY) {
/*
* Windows 95 reports removing a directory as ENOENT instead
* of EISDIR.
*/
- errno = EISDIR;
+ Tcl_SetErrno(EISDIR);
}
}
- } else if (errno == EINVAL) {
+ } else if (Tcl_GetErrno() == EINVAL) {
/*
* Windows NT reports removing a char device as EINVAL instead of
* EACCES.
*/
- errno = EACCES;
+ Tcl_SetErrno(EACCES);
}
return TCL_ERROR;
@@ -542,15 +666,31 @@ TclpDeleteFile(
int
TclpCreateDirectory(
- char *path) /* Pathname of directory to create */
+ CONST char *path) /* Pathname of directory to create (UTF-8). */
+{
+ int result;
+ Tcl_DString pathString;
+
+ Tcl_WinUtfToTChar(path, -1, &pathString);
+ result = DoCreateDirectory(&pathString);
+ Tcl_DStringFree(&pathString);
+ return result;
+}
+
+static int
+DoCreateDirectory(
+ Tcl_DString *pathPtr) /* Pathname of directory to create (native). */
{
int error;
+ CONST TCHAR *nativePath;
- if (CreateDirectory(path, NULL) == 0) {
+ nativePath = (TCHAR *) Tcl_DStringValue(pathPtr);
+ if ((*tclWinProcs->createDirectoryProc)(nativePath, NULL) == 0) {
error = GetLastError();
if (TclWinGetPlatformId() == VER_PLATFORM_WIN32s) {
if ((error == ERROR_ACCESS_DENIED)
- && (GetFileAttributes(path) != (DWORD) -1)) {
+ && ((*tclWinProcs->getFileAttributesProc)(nativePath)
+ != 0xffffffff)) {
error = ERROR_FILE_EXISTS;
}
}
@@ -588,30 +728,30 @@ TclpCreateDirectory(
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. */
+ CONST char *src, /* Pathname of directory to be copied
+ * (UTF-8). */
+ CONST char *dst, /* Pathname of target directory (UTF-8). */
+ Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free
+ * DString filled with UTF-8 name of file
+ * causing error. */
{
int result;
- Tcl_DString 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);
+ Tcl_DString srcString, dstString;
+
+ Tcl_WinUtfToTChar(src, -1, &srcString);
+ Tcl_WinUtfToTChar(dst, -1, &dstString);
+
+ result = TraverseWinTree(TraversalCopy, &srcString, &dstString, errorPtr);
+
+ Tcl_DStringFree(&srcString);
+ Tcl_DStringFree(&dstString);
return result;
}
/*
*----------------------------------------------------------------------
*
- * TclpRemoveDirectory --
+ * TclpRemoveDirectory, DoRemoveDirectory --
*
* Removes directory (and its contents, if the recursive flag is set).
*
@@ -639,52 +779,87 @@ TclpCopyDirectory(
int
TclpRemoveDirectory(
- char *path, /* Pathname of directory to be removed. */
+ CONST char *path, /* Pathname of directory to be removed
+ * (UTF-8). */
int recursive, /* If non-zero, removes directories that
* are nonempty. Otherwise, will only remove
* empty directories. */
- Tcl_DString *errorPtr) /* If non-NULL, initialized DString for
- * error reporting. */
+ Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free
+ * DString filled with UTF-8 name of file
+ * causing error. */
{
int result;
- Tcl_DString buffer;
+ Tcl_DString pathString;
+
+ Tcl_WinUtfToTChar(path, -1, &pathString);
+ result = DoRemoveDirectory(&pathString, recursive, errorPtr);
+ Tcl_DStringFree(&pathString);
+
+ return result;
+}
+
+static int
+DoRemoveDirectory(
+ Tcl_DString *pathPtr, /* Pathname of directory to be removed
+ * (native). */
+ int recursive, /* If non-zero, removes directories that
+ * are nonempty. Otherwise, will only remove
+ * empty directories. */
+ Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free
+ * DString filled with UTF-8 name of file
+ * causing error. */
+{
+ CONST TCHAR *nativePath;
DWORD attr;
- if (RemoveDirectory(path) != FALSE) {
+ nativePath = (TCHAR *) Tcl_DStringValue(pathPtr);
+
+ if ((*tclWinProcs->removeDirectoryProc)(nativePath) != 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;
+ /*
+ * Win32s thinks that "" is the same as "." and then reports EACCES
+ * instead of ENOENT.
+ */
+
+
+ if (tclWinProcs->useWide) {
+ if (((WCHAR *) nativePath)[0] == '\0') {
+ Tcl_SetErrno(ENOENT);
+ return TCL_ERROR;
+ }
+ } else {
+ if (((char *) nativePath)[0] == '\0') {
+ Tcl_SetErrno(ENOENT);
+ return TCL_ERROR;
+ }
}
- if (errno == EACCES) {
- attr = GetFileAttributes(path);
- if (attr != (DWORD) -1) {
+ if (Tcl_GetErrno() == EACCES) {
+ attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
+ if (attr != 0xffffffff) {
if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
/*
* Windows 95 reports calling RemoveDirectory on a file as an
* EACCES, not an ENOTDIR.
*/
- errno = ENOTDIR;
+ Tcl_SetErrno(ENOTDIR);
goto end;
}
if (attr & FILE_ATTRIBUTE_READONLY) {
attr &= ~FILE_ATTRIBUTE_READONLY;
- if (SetFileAttributes(path, attr) == FALSE) {
+ if ((*tclWinProcs->setFileAttributesProc)(nativePath, attr) == FALSE) {
goto end;
}
- if (RemoveDirectory(path) != FALSE) {
+ if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) {
return TCL_OK;
}
TclWinConvertError(GetLastError());
- SetFileAttributes(path, attr | FILE_ATTRIBUTE_READONLY);
+ (*tclWinProcs->setFileAttributesProc)(nativePath,
+ attr | FILE_ATTRIBUTE_READONLY);
}
/*
@@ -694,20 +869,22 @@ TclpRemoveDirectory(
*/
if (TclWinGetPlatformId() != VER_PLATFORM_WIN32_NT) {
+ char *path, *find;
HANDLE handle;
- WIN32_FIND_DATA data;
+ WIN32_FIND_DATAA data;
Tcl_DString buffer;
- char *find;
int len;
+ path = (char *) nativePath;
+
Tcl_DStringInit(&buffer);
- find = Tcl_DStringAppend(&buffer, path, -1);
- len = Tcl_DStringLength(&buffer);
+ len = strlen(path);
+ find = Tcl_DStringAppend(&buffer, path, len);
if ((len > 0) && (find[len - 1] != '\\')) {
Tcl_DStringAppend(&buffer, "\\", 1);
}
find = Tcl_DStringAppend(&buffer, "*.*", 3);
- handle = FindFirstFile(find, &data);
+ handle = FindFirstFileA(find, &data);
if (handle != INVALID_HANDLE_VALUE) {
while (1) {
if ((strcmp(data.cFileName, ".") != 0)
@@ -716,10 +893,10 @@ TclpRemoveDirectory(
* Found something in this directory.
*/
- errno = EEXIST;
+ Tcl_SetErrno(EEXIST);
break;
}
- if (FindNextFile(handle, &data) == FALSE) {
+ if (FindNextFileA(handle, &data) == FALSE) {
break;
}
}
@@ -729,30 +906,26 @@ TclpRemoveDirectory(
}
}
}
- if (errno == ENOTEMPTY) {
+ if (Tcl_GetErrno() == ENOTEMPTY) {
/*
* The caller depends on EEXIST to signify that the directory is
* not empty, not ENOTEMPTY.
*/
- errno = EEXIST;
+ Tcl_SetErrno(EEXIST);
}
- if ((recursive != 0) && (errno == EEXIST)) {
+ if ((recursive != 0) && (Tcl_GetErrno() == EEXIST)) {
/*
* The directory is nonempty, but the recursive flag has been
* specified, so we recursively remove all the files in the directory.
*/
- Tcl_DStringInit(&buffer);
- Tcl_DStringAppend(&buffer, path, -1);
- result = TraverseWinTree(TraversalDelete, &buffer, NULL, errorPtr);
- Tcl_DStringFree(&buffer);
- return result;
+ return TraverseWinTree(TraversalDelete, pathPtr, NULL, errorPtr);
}
-
+
end:
if (errorPtr != NULL) {
- Tcl_DStringAppend(errorPtr, path, -1);
+ Tcl_WinTCharToUtf(nativePath, -1, errorPtr);
}
return TCL_ERROR;
}
@@ -784,34 +957,28 @@ TraverseWinTree(
TraversalProc *traverseProc,/* Function to call for every file and
* directory in source hierarchy. */
Tcl_DString *sourcePtr, /* Pathname of source directory to be
- * traversed. */
+ * traversed (native). */
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. */
+ * parallel with source directory (native). */
+ Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free
+ * DString filled with UTF-8 name of file
+ * causing error. */
{
DWORD sourceAttr;
- char *source, *target, *errfile;
- int result, sourceLen, targetLen, sourceLenOriginal, targetLenOriginal;
+ TCHAR *nativeSource, *nativeErrfile;
+ int result, found, sourceLen, targetLen, oldSourceLen, oldTargetLen;
HANDLE handle;
- WIN32_FIND_DATA data;
+ WIN32_FIND_DATAT data;
+ nativeErrfile = NULL;
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;
+ oldTargetLen = 0; /* lint. */
- sourceAttr = GetFileAttributes(source);
- if (sourceAttr == (DWORD) -1) {
- errfile = source;
+ nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr);
+ oldSourceLen = Tcl_DStringLength(sourcePtr);
+ sourceAttr = (*tclWinProcs->getFileAttributesProc)(nativeSource);
+ if (sourceAttr == 0xffffffff) {
+ nativeErrfile = nativeSource;
goto end;
}
if ((sourceAttr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
@@ -819,76 +986,112 @@ TraverseWinTree(
* Process the regular file
*/
- return (*traverseProc)(source, target, sourceAttr, DOTREE_F, errorPtr);
+ return (*traverseProc)(sourcePtr, targetPtr, 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++;
+ if (tclWinProcs->useWide) {
+ Tcl_DStringAppend(sourcePtr, (char *) L"\\*.*", 4 * sizeof(WCHAR) + 1);
+ Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1);
+ } else {
+ Tcl_DStringAppend(sourcePtr, "\\*.*", 4);
}
- source = Tcl_DStringAppend(sourcePtr, "*.*", 3);
- handle = FindFirstFile(source, &data);
- Tcl_DStringSetLength(sourcePtr, sourceLen);
- if (handle == INVALID_HANDLE_VALUE) {
+ nativeSource = (TCHAR *) Tcl_DStringValue(sourcePtr);
+ handle = (*tclWinProcs->findFirstFileProc)(nativeSource, &data);
+ if (handle == INVALID_HANDLE_VALUE) {
/*
* Can't read directory
*/
TclWinConvertError(GetLastError());
- errfile = source;
+ nativeErrfile = nativeSource;
goto end;
}
- result = (*traverseProc)(source, target, sourceAttr, DOTREE_PRED, errorPtr);
+ nativeSource[oldSourceLen + 1] = '\0';
+ Tcl_DStringSetLength(sourcePtr, oldSourceLen);
+ result = (*traverseProc)(sourcePtr, targetPtr, DOTREE_PRED, errorPtr);
if (result != TCL_OK) {
FindClose(handle);
return result;
}
+ sourceLen = oldSourceLen;
+
+ if (tclWinProcs->useWide) {
+ sourceLen += sizeof(WCHAR);
+ Tcl_DStringAppend(sourcePtr, (char *) L"\\", sizeof(WCHAR) + 1);
+ Tcl_DStringSetLength(sourcePtr, sourceLen);
+ } else {
+ sourceLen += 1;
+ Tcl_DStringAppend(sourcePtr, "\\", 1);
+ }
if (targetPtr != NULL) {
- targetLen = targetLenOriginal;
- if ((targetLen > 0) && (target[targetLen - 1] != '\\')) {
- target = Tcl_DStringAppend(targetPtr, "\\", 1);
- targetLen++;
+ oldTargetLen = Tcl_DStringLength(targetPtr);
+
+ targetLen = oldTargetLen;
+ if (tclWinProcs->useWide) {
+ targetLen += sizeof(WCHAR);
+ Tcl_DStringAppend(targetPtr, (char *) L"\\", sizeof(WCHAR) + 1);
+ Tcl_DStringSetLength(targetPtr, targetLen);
+ } else {
+ targetLen += 1;
+ Tcl_DStringAppend(targetPtr, "\\", 1);
}
}
- while (1) {
- if ((strcmp(data.cFileName, ".") != 0)
- && (strcmp(data.cFileName, "..") != 0)) {
- /*
- * Append name after slash, and recurse on the file.
- */
+ found = 1;
+ for ( ; found; found = (*tclWinProcs->findNextFileProc)(handle, &data)) {
+ TCHAR *nativeName;
+ int len;
+
+ if (tclWinProcs->useWide) {
+ WCHAR *wp;
- Tcl_DStringAppend(sourcePtr, data.cFileName, -1);
- if (targetPtr != NULL) {
- Tcl_DStringAppend(targetPtr, data.cFileName, -1);
+ wp = data.w.cFileName;
+ if (*wp == '.') {
+ wp++;
+ if (*wp == '.') {
+ wp++;
+ }
+ if (*wp == '\0') {
+ continue;
+ }
}
- result = TraverseWinTree(traverseProc, sourcePtr, targetPtr,
- errorPtr);
- if (result != TCL_OK) {
- break;
+ nativeName = (TCHAR *) data.w.cFileName;
+ len = TclUniCharLen(data.w.cFileName) * sizeof(WCHAR);
+ } else {
+ if ((strcmp(data.a.cFileName, ".") == 0)
+ || (strcmp(data.a.cFileName, "..") == 0)) {
+ continue;
}
+ nativeName = (TCHAR *) data.a.cFileName;
+ len = strlen(data.a.cFileName);
+ }
- /*
- * Remove name after slash.
- */
+ /*
+ * Append name after slash, and recurse on the file.
+ */
- Tcl_DStringSetLength(sourcePtr, sourceLen);
- if (targetPtr != NULL) {
- Tcl_DStringSetLength(targetPtr, targetLen);
- }
+ Tcl_DStringAppend(sourcePtr, (char *) nativeName, len + 1);
+ Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1);
+ if (targetPtr != NULL) {
+ Tcl_DStringAppend(targetPtr, (char *) nativeName, len + 1);
+ Tcl_DStringSetLength(targetPtr, Tcl_DStringLength(targetPtr) - 1);
}
- if (FindNextFile(handle, &data) == FALSE) {
+ result = TraverseWinTree(traverseProc, sourcePtr, targetPtr,
+ errorPtr);
+ if (result != TCL_OK) {
break;
}
+
+ /*
+ * Remove name after slash.
+ */
+
+ Tcl_DStringSetLength(sourcePtr, sourceLen);
+ if (targetPtr != NULL) {
+ Tcl_DStringSetLength(targetPtr, targetLen);
+ }
}
FindClose(handle);
@@ -896,27 +1099,26 @@ TraverseWinTree(
* Strip off the trailing slash we added
*/
- Tcl_DStringSetLength(sourcePtr, sourceLenOriginal);
- source = Tcl_DStringValue(sourcePtr);
+ Tcl_DStringSetLength(sourcePtr, oldSourceLen + 1);
+ Tcl_DStringSetLength(sourcePtr, oldSourceLen);
if (targetPtr != NULL) {
- Tcl_DStringSetLength(targetPtr, targetLenOriginal);
- target = Tcl_DStringValue(targetPtr);
+ Tcl_DStringSetLength(targetPtr, oldTargetLen + 1);
+ Tcl_DStringSetLength(targetPtr, oldTargetLen);
}
-
if (result == TCL_OK) {
/*
* Call traverseProc() on a directory after visiting all the
* files in that directory.
*/
- result = (*traverseProc)(source, target, sourceAttr,
- DOTREE_POSTD, errorPtr);
+ result = (*traverseProc)(sourcePtr, targetPtr, DOTREE_POSTD,
+ errorPtr);
}
end:
- if (errfile != NULL) {
+ if (nativeErrfile != NULL) {
TclWinConvertError(GetLastError());
if (errorPtr != NULL) {
- Tcl_DStringAppend(errorPtr, errfile, -1);
+ Tcl_WinTCharToUtf(nativeErrfile, -1, errorPtr);
}
result = TCL_ERROR;
}
@@ -943,32 +1145,37 @@ TraverseWinTree(
static int
TraversalCopy(
- char *src, /* Source pathname to copy. */
- char *dst, /* Destination pathname of copy. */
- DWORD srcAttr, /* File attributes for src. */
+ Tcl_DString *srcPtr, /* Source pathname to copy. */
+ Tcl_DString *dstPtr, /* Destination pathname of copy. */
int type, /* Reason for call - see TraverseWinTree() */
- Tcl_DString *errorPtr) /* If non-NULL, initialized DString for
- * error return. */
+ Tcl_DString *errorPtr) /* If non-NULL, initialized DString filled
+ * with UTF-8 name of file causing error. */
{
+ TCHAR *nativeDst, *nativeSrc;
+ DWORD attr;
+
switch (type) {
- case DOTREE_F:
- if (TclpCopyFile(src, dst) == TCL_OK) {
+ case DOTREE_F: {
+ if (DoCopyFile(srcPtr, dstPtr) == TCL_OK) {
return TCL_OK;
}
break;
-
- case DOTREE_PRED:
- if (TclpCreateDirectory(dst) == TCL_OK) {
- if (SetFileAttributes(dst, srcAttr) != FALSE) {
+ }
+ case DOTREE_PRED: {
+ if (DoCreateDirectory(dstPtr) == TCL_OK) {
+ nativeSrc = (TCHAR *) Tcl_DStringValue(srcPtr);
+ nativeDst = (TCHAR *) Tcl_DStringValue(dstPtr);
+ attr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
+ if ((*tclWinProcs->setFileAttributesProc)(nativeDst, attr) != FALSE) {
return TCL_OK;
}
TclWinConvertError(GetLastError());
}
break;
-
- case DOTREE_POSTD:
+ }
+ case DOTREE_POSTD: {
return TCL_OK;
-
+ }
}
/*
@@ -977,7 +1184,8 @@ TraversalCopy(
*/
if (errorPtr != NULL) {
- Tcl_DStringAppend(errorPtr, dst, -1);
+ nativeDst = (TCHAR *) Tcl_DStringValue(dstPtr);
+ Tcl_WinTCharToUtf(nativeDst, -1, errorPtr);
}
return TCL_ERROR;
}
@@ -1005,33 +1213,35 @@ TraversalCopy(
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. */
+ Tcl_DString *srcPtr, /* Source pathname to delete. */
+ Tcl_DString *dstPtr, /* Not used. */
+ int type, /* Reason for call - see TraverseWinTree() */
+ Tcl_DString *errorPtr) /* If non-NULL, initialized DString filled
+ * with UTF-8 name of file causing error. */
{
+ TCHAR *nativeSrc;
+
switch (type) {
- case DOTREE_F:
- if (TclpDeleteFile(src) == TCL_OK) {
+ case DOTREE_F: {
+ if (DoDeleteFile(srcPtr) == TCL_OK) {
return TCL_OK;
}
break;
-
- case DOTREE_PRED:
+ }
+ case DOTREE_PRED: {
return TCL_OK;
-
- case DOTREE_POSTD:
- if (TclpRemoveDirectory(src, 0, NULL) == TCL_OK) {
+ }
+ case DOTREE_POSTD: {
+ if (DoRemoveDirectory(srcPtr, 0, NULL) == TCL_OK) {
return TCL_OK;
}
break;
-
+ }
}
if (errorPtr != NULL) {
- Tcl_DStringAppend(errorPtr, src, -1);
+ nativeSrc = (TCHAR *) Tcl_DStringValue(srcPtr);
+ Tcl_WinTCharToUtf(nativeSrc, -1, errorPtr);
}
return TCL_ERROR;
}
@@ -1039,7 +1249,7 @@ TraversalDelete(
/*
*----------------------------------------------------------------------
*
- * AttributesPosixError --
+ * StatError --
*
* Sets the object result with the appropriate error.
*
@@ -1054,18 +1264,15 @@ TraversalDelete(
*/
static void
-AttributesPosixError(
+StatError(
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
+ CONST 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);
+ "could not read \"", fileName, "\": ", Tcl_PosixError(interp),
+ (char *) NULL);
}
/*
@@ -1089,15 +1296,21 @@ AttributesPosixError(
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. */
+ Tcl_Interp *interp, /* The interp we are using for errors. */
+ int objIndex, /* The index of the attribute. */
+ CONST char *fileName, /* The name of the file. */
+ Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
- DWORD result = GetFileAttributes(fileName);
+ DWORD result;
+ Tcl_DString ds;
+ TCHAR *nativeName;
+
+ nativeName = Tcl_WinUtfToTChar(fileName, -1, &ds);
+ result = (*tclWinProcs->getFileAttributesProc)(nativeName);
+ Tcl_DStringFree(&ds);
- if (result == 0xFFFFFFFF) {
- AttributesPosixError(interp, objIndex, fileName, 0);
+ if (result == 0xffffffff) {
+ StatError(interp, fileName);
return TCL_ERROR;
}
@@ -1126,87 +1339,129 @@ GetWinFileAttributes(
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. */
+ Tcl_Interp *interp, /* The interp we are using for errors. */
+ int objIndex, /* The index of the attribute. */
+ CONST char *fileName, /* The name of the file. */
+ int longShort, /* 0 to short name, 1 to long name. */
+ Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
- HANDLE findHandle;
- WIN32_FIND_DATA findData;
- int pathArgc, i;
- char **pathArgv, **newPathArgv;
- char *currentElement, *resultStr;
+ int pathc, i;
+ char **pathv, **newv;
+ char *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, "..");
+ Tcl_SplitPath(fileName, &pathc, &pathv);
+ newv = (char **) ckalloc(pathc * sizeof(char *));
+
+ for (i = 0; i < pathc; i++) {
+ if ((pathv[i][0] == '/')
+ || ((strlen(pathv[i]) == 3) && (pathv[i][1] == ':'))
+ || (strcmp(pathv[i], ".") == 0)
+ || (strcmp(pathv[i], "..") == 0)) {
+ /*
+ * Handle "/", "//machine/export", "c:/", "." or ".." by just
+ * copying the string literally. Uppercase the drive letter,
+ * just because it looks better under Windows to do so.
+ */
+
+ simple:
+ pathv[i][0] = (char) Tcl_UniCharToUpper(UCHAR(pathv[i][0]));
+ newv[i] = (char *) ckalloc(strlen(pathv[i]) + 1);
+ lstrcpyA(newv[i], pathv[i]);
} else {
- int useLong;
+ char *str;
+ TCHAR *nativeName;
+ Tcl_DString ds;
+ WIN32_FIND_DATAT data;
+ HANDLE handle;
+ DWORD attr;
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);
+ str = Tcl_JoinPath(i + 1, pathv, &resultDString);
+ nativeName = Tcl_WinUtfToTChar(str, -1, &ds);
+ handle = (*tclWinProcs->findFirstFileProc)(nativeName, &data);
+ if (handle == INVALID_HANDLE_VALUE) {
+ /*
+ * FindFirstFile() doesn't like root directories. We
+ * would only get a root directory here if the caller
+ * specified "c:" or "c:." and the current directory on the
+ * drive was the root directory
+ */
+
+ attr = (*tclWinProcs->getFileAttributesProc)(nativeName);
+ if ((attr != 0xFFFFFFFF) && (attr & FILE_ATTRIBUTE_DIRECTORY)) {
+ Tcl_DStringFree(&ds);
+ Tcl_DStringFree(&resultDString);
+
+ goto simple;
+ }
+ }
+ Tcl_DStringFree(&ds);
+ Tcl_DStringFree(&resultDString);
+
+ if (handle == INVALID_HANDLE_VALUE) {
+ pathc = i - 1;
+ StatError(interp, fileName);
result = TCL_ERROR;
- Tcl_DStringFree(&resultDString);
goto cleanup;
}
- if (longShort) {
- if (findData.cFileName[0] != '\0') {
- useLong = 1;
+ if (tclWinProcs->useWide) {
+ nativeName = (TCHAR *) data.w.cAlternateFileName;
+ if (longShort) {
+ if (data.w.cFileName[0] != '\0') {
+ nativeName = (TCHAR *) data.w.cFileName;
+ }
} else {
- useLong = 0;
+ if (data.w.cAlternateFileName[0] == '\0') {
+ nativeName = (TCHAR *) data.w.cFileName;
+ }
}
} else {
- if (findData.cAlternateFileName[0] == '\0') {
- useLong = 1;
+ nativeName = (TCHAR *) data.a.cAlternateFileName;
+ if (longShort) {
+ if (data.a.cFileName[0] != '\0') {
+ nativeName = (TCHAR *) data.a.cFileName;
+ }
} else {
- useLong = 0;
+ if (data.a.cAlternateFileName[0] == '\0') {
+ nativeName = (TCHAR *) data.a.cFileName;
+ }
}
}
- 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);
+
+ /*
+ * Purify reports a extraneous UMR in Tcl_WinTCharToUtf() trying
+ * to dereference nativeName as a Unicode string. I have proven
+ * to myself that purify is wrong by running the following
+ * example when nativeName == data.w.cAlternateFileName and
+ * noting that purify doesn't complain about the first line,
+ * but does complain about the second.
+ *
+ * fprintf(stderr, "%d\n", data.w.cAlternateFileName[0]);
+ * fprintf(stderr, "%d\n", ((WCHAR *) nativeName)[0]);
+ */
+
+ Tcl_WinTCharToUtf(nativeName, -1, &ds);
+ newv[i] = ckalloc(Tcl_DStringLength(&ds) + 1);
+ lstrcpyA(newv[i], Tcl_DStringValue(&ds));
+ Tcl_DStringFree(&ds);
+ FindClose(handle);
}
- newPathArgv[i] = currentElement;
}
Tcl_DStringInit(&resultDString);
- resultStr = Tcl_JoinPath(pathArgc, newPathArgv, &resultDString);
- *attributePtrPtr = Tcl_NewStringObj(resultStr, Tcl_DStringLength(&resultDString));
+ resultStr = Tcl_JoinPath(pathc, newv, &resultDString);
+ *attributePtrPtr = Tcl_NewStringObj(resultStr,
+ Tcl_DStringLength(&resultDString));
Tcl_DStringFree(&resultDString);
cleanup:
- for (i = 0; i < pathArgc; i++) {
- ckfree(newPathArgv[i]);
+ for (i = 0; i < pathc; i++) {
+ ckfree(newv[i]);
}
- ckfree((char *) newPathArgv);
+ ckfree((char *) newv);
+ ckfree((char *) pathv);
return result;
}
@@ -1231,10 +1486,10 @@ cleanup:
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. */
+ Tcl_Interp *interp, /* The interp we are using for errors. */
+ int objIndex, /* The index of the attribute. */
+ CONST char *fileName, /* The name of the file. */
+ Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
return ConvertFileNameFormat(interp, objIndex, fileName, 1, attributePtrPtr);
}
@@ -1260,10 +1515,10 @@ GetWinFileLongName(
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. */
+ Tcl_Interp *interp, /* The interp we are using for errors. */
+ int objIndex, /* The index of the attribute. */
+ CONST char *fileName, /* The name of the file. */
+ Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
return ConvertFileNameFormat(interp, objIndex, fileName, 0, attributePtrPtr);
}
@@ -1287,23 +1542,29 @@ GetWinFileShortName(
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. */
+ Tcl_Interp *interp, /* The interp we are using for errors. */
+ int objIndex, /* The index of the attribute. */
+ CONST char *fileName, /* The name of the file. */
+ Tcl_Obj *attributePtr) /* The new value of the attribute. */
{
- DWORD fileAttributes = GetFileAttributes(fileName);
+ DWORD fileAttributes;
int yesNo;
int result;
+ Tcl_DString ds;
+ TCHAR *nativeName;
- if (fileAttributes == 0xFFFFFFFF) {
- AttributesPosixError(interp, objIndex, fileName, 1);
- return TCL_ERROR;
+ nativeName = Tcl_WinUtfToTChar(fileName, -1, &ds);
+ fileAttributes = (*tclWinProcs->getFileAttributesProc)(nativeName);
+
+ if (fileAttributes == 0xffffffff) {
+ StatError(interp, fileName);
+ result = TCL_ERROR;
+ goto end;
}
result = Tcl_GetBooleanFromObj(interp, attributePtr, &yesNo);
if (result != TCL_OK) {
- return result;
+ goto end;
}
if (yesNo) {
@@ -1312,11 +1573,16 @@ SetWinFileAttributes(
fileAttributes &= ~(attributeArray[objIndex]);
}
- if (!SetFileAttributes(fileName, fileAttributes)) {
- AttributesPosixError(interp, objIndex, fileName, 1);
- return TCL_ERROR;
+ if (!(*tclWinProcs->setFileAttributesProc)(nativeName, fileAttributes)) {
+ StatError(interp, fileName);
+ result = TCL_ERROR;
+ goto end;
}
- return TCL_OK;
+
+ end:
+ Tcl_DStringFree(&ds);
+
+ return result;
}
/*
@@ -1338,14 +1604,14 @@ SetWinFileAttributes(
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_Interp *interp, /* The interp we are using for errors. */
+ int objIndex, /* The index of the attribute. */
+ CONST char *fileName, /* The name of the file. */
+ Tcl_Obj *attributePtr) /* The new value of the attribute. */
{
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"cannot set attribute \"", tclpFileAttrStrings[objIndex],
- "\" for file \"", fileName, "\" : attribute is readonly",
+ "\" for file \"", fileName, "\": attribute is readonly",
(char *) NULL);
return TCL_ERROR;
}
@@ -1371,29 +1637,47 @@ CannotSetAttribute(
int
TclpListVolumes(
- Tcl_Interp *interp) /* Interpreter to which to pass the volume list */
+ Tcl_Interp *interp) /* Interpreter for returning volume list. */
{
Tcl_Obj *resultPtr, *elemPtr;
- char buf[4];
+ char buf[40 * 4]; /* There couldn't be more than 30 drives??? */
int i;
+ char *p;
resultPtr = Tcl_GetObjResult(interp);
- buf[1] = ':';
- buf[2] = '/';
- buf[3] = '\0';
-
/*
- * On Win32s:
+ * 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);
+ if (GetLogicalDriveStringsA(sizeof(buf), buf) == 0) {
+ /*
+ * GetVolumeInformation() will detects all drives, but causes
+ * chattering on empty floppy drives. We only do this if
+ * GetLogicalDriveStrings() didn't work. It has also been reported
+ * that on some laptops it takes a while for GetVolumeInformation()
+ * to return when pinging an empty floppy drive, another reason to
+ * try to avoid calling it.
+ */
+
+ buf[1] = ':';
+ buf[2] = '/';
+ buf[3] = '\0';
+
+ for (i = 0; i < 26; i++) {
+ buf[0] = (char) ('a' + i);
+ if (GetVolumeInformationA(buf, NULL, 0, NULL, NULL, NULL, NULL, 0)
+ || (GetLastError() == ERROR_NOT_READY)) {
+ elemPtr = Tcl_NewStringObj(buf, -1);
+ Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr);
+ }
+ }
+ } else {
+ for (p = buf; *p != '\0'; p += 4) {
+ p[2] = '/';
+ elemPtr = Tcl_NewStringObj(p, -1);
Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr);
}
}
diff --git a/win/tclWinFile.c b/win/tclWinFile.c
index 9d97b02..889994c1 100644
--- a/win/tclWinFile.c
+++ b/win/tclWinFile.c
@@ -6,25 +6,29 @@
* files, which can be manipulated through the Win32 console redirection
* interfaces.
*
- * Copyright (c) 1995-1996 Sun Microsystems, Inc.
+ * Copyright (c) 1995-1998 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclWinFile.c 1.45 97/10/29 19:08:35
+ * SCCS: @(#) tclWinFile.c 1.59 98/02/02 22:07:09
*/
#include "tclWinInt.h"
#include <sys/stat.h>
#include <shlobj.h>
+#include <lmaccess.h> /* For TclpGetUserHome(). */
-/*
- * 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 time_t ToCTime(FILETIME fileTime);
+
+typedef NET_API_STATUS NET_API_FUNCTION NETUSERGETINFOPROC
+ (LPWSTR servername, LPWSTR username, DWORD level, LPBYTE *bufptr);
-static char *currentDir = NULL;
+typedef NET_API_STATUS NET_API_FUNCTION NETAPIBUFFERFREEPROC
+ (LPVOID Buffer);
+
+typedef NET_API_STATUS NET_API_FUNCTION NETGETDCNAMEPROC
+ (LPWSTR servername, LPWSTR domainname, LPBYTE *bufptr);
/*
@@ -48,15 +52,18 @@ static char *currentDir = NULL;
void
Tcl_FindExecutable(argv0)
- char *argv0; /* The value of the application's argv[0]. */
+ CONST char *argv0; /* The value of the application's argv[0]. */
{
- Tcl_DString buffer;
- int length;
+ Tcl_DString ds;
+ WCHAR wName[MAX_PATH];
- Tcl_DStringInit(&buffer);
+ TclInitSubsystems(argv0);
+ if (argv0 == NULL) {
+ return;
+ }
if (tclExecutableName != NULL) {
- ckfree(tclExecutableName);
+ ckfree((char *) tclExecutableName);
tclExecutableName = NULL;
}
@@ -65,26 +72,26 @@ Tcl_FindExecutable(argv0)
* 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);
+ (*tclWinProcs->getModuleFileNameProc)(NULL, wName, MAX_PATH);
+ Tcl_WinTCharToUtf((TCHAR *) wName, -1, &ds);
+
+ tclExecutableName = ckalloc((unsigned) (Tcl_DStringLength(&ds) + 1));
+ strcpy(tclExecutableName, Tcl_DStringValue(&ds));
+ TclWinNoBackslash(tclExecutableName);
+ Tcl_DStringFree(&ds);
}
/*
*----------------------------------------------------------------------
*
- * TclMatchFiles --
+ * TclpMatchFiles --
*
* 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
+ * added to the the interp's result. Otherwise, TclDoGlob is called
* recursively for each matching subdirectory. The return value
* is a standard Tcl result indicating whether an error occurred
* in globbing.
@@ -95,7 +102,7 @@ Tcl_FindExecutable(argv0)
*---------------------------------------------------------------------- */
int
-TclMatchFiles(interp, separators, dirPtr, pattern, tail)
+TclpMatchFiles(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. */
@@ -103,17 +110,18 @@ TclMatchFiles(interp, separators, dirPtr, pattern, tail)
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;
+ char drivePat[] = "?:\\";
+ const char *message;
+ char *dir, *newPattern, *root;
+ int matchDotFiles;
+ int dirLength, result = TCL_OK;
+ Tcl_DString dirString, patternString;
+ DWORD attr, volFlags;
HANDLE handle;
- WIN32_FIND_DATA data;
+ WIN32_FIND_DATAT data;
BOOL found;
+ Tcl_DString ds;
+ TCHAR *nativeName;
/*
* Convert the path to normalized form since some interfaces only
@@ -121,31 +129,37 @@ TclMatchFiles(interp, separators, dirPtr, pattern, tail)
* separator character.
*/
- Tcl_DStringInit(&buffer);
- if (baseLength == 0) {
- Tcl_DStringAppend(&buffer, ".", 1);
+ dirLength = Tcl_DStringLength(dirPtr);
+ Tcl_DStringInit(&dirString);
+ if (dirLength == 0) {
+ Tcl_DStringAppend(&dirString, ".\\", 2);
} else {
- Tcl_DStringAppend(&buffer, Tcl_DStringValue(dirPtr),
+ char *p;
+
+ Tcl_DStringAppend(&dirString, Tcl_DStringValue(dirPtr),
Tcl_DStringLength(dirPtr));
- }
- for (p = Tcl_DStringValue(&buffer); *p != '\0'; p++) {
- if (*p == '/') {
- *p = '\\';
+ for (p = Tcl_DStringValue(&dirString); *p != '\0'; p++) {
+ if (*p == '/') {
+ *p = '\\';
+ }
+ }
+ p--;
+ if ((*p != '\\') && (*p != ':')) {
+ Tcl_DStringAppend(&dirString, "\\", 1);
}
}
- p--;
- if (*p != '\\' && *p != ':') {
- Tcl_DStringAppend(&buffer, "\\", 1);
- }
- dir = Tcl_DStringValue(&buffer);
-
+ dir = Tcl_DStringValue(&dirString);
+
/*
* First verify that the specified path is actually a directory.
*/
- atts = GetFileAttributes(dir);
- if ((atts == 0xFFFFFFFF) || ((atts & FILE_ATTRIBUTE_DIRECTORY) == 0)) {
- Tcl_DStringFree(&buffer);
+ nativeName = Tcl_WinUtfToTChar(dir, Tcl_DStringLength(&dirString), &ds);
+ attr = (*tclWinProcs->getFileAttributesProc)(nativeName);
+ Tcl_DStringFree(&ds);
+
+ if ((attr == 0xffffffff) || ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0)) {
+ Tcl_DStringFree(&dirString);
return TCL_OK;
}
@@ -158,82 +172,69 @@ TclMatchFiles(interp, separators, dirPtr, pattern, tail)
switch (Tcl_GetPathType(dir)) {
case TCL_PATH_RELATIVE:
- found = GetVolumeInformation(NULL, NULL, 0, NULL,
- NULL, &volFlags, NULL, 0);
+ found = GetVolumeInformationA(NULL, NULL, 0, NULL, NULL,
+ &volFlags, NULL, 0);
break;
case TCL_PATH_VOLUME_RELATIVE:
- if (*dir == '\\') {
+ if (dir[0] == '\\') {
root = NULL;
} else {
- root = drivePattern;
- *root = *dir;
+ root = drivePat;
+ *root = dir[0];
}
- found = GetVolumeInformation(root, NULL, 0, NULL,
- NULL, &volFlags, NULL, 0);
+ found = GetVolumeInformationA(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);
+ root = drivePat;
+ *root = dir[0];
+ found = GetVolumeInformationA(root, NULL, 0, NULL, NULL,
+ &volFlags, NULL, 0);
} else if (dir[1] == '\\') {
- p = strchr(dir+2, '\\');
- p = strchr(p+1, '\\');
+ char *p;
+
+ 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;
+ nativeName = Tcl_WinUtfToTChar(dir, p - dir, &ds);
+ found = (*tclWinProcs->getVolumeInformationProc)(nativeName,
+ NULL, 0, NULL, NULL, &volFlags, NULL, 0);
+ Tcl_DStringFree(&ds);
}
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;
+ if (found == 0) {
+ message = "couldn't read volume information for \"";
+ goto error;
}
-
+
/*
* In Windows, although some volumes may support case sensitivity, Windows
* doesn't honor case. So in globbing we need to ignore the case
* of file names.
*/
- length = tail - pattern;
- newPattern = ckalloc(length+1);
- for (src = pattern, dest = newPattern; src < tail; src++, dest++) {
- *dest = (char) tolower(*src);
+ Tcl_DStringInit(&patternString);
+ newPattern = Tcl_DStringAppend(&patternString, pattern, tail - pattern);
+ if ((volFlags & FS_CASE_SENSITIVE) == 0) {
+ Tcl_UtfToLower(newPattern);
}
- *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);
+ dir = Tcl_DStringAppend(&dirString, "*.*", 3);
+ nativeName = Tcl_WinUtfToTChar(dir, -1, &ds);
+ handle = (*tclWinProcs->findFirstFileProc)(nativeName, &data);
+ Tcl_DStringFree(&ds);
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;
+ message = "couldn't read directory \"";
+ goto error;
}
/*
@@ -265,17 +266,17 @@ TclMatchFiles(interp, separators, dirPtr, pattern, tail)
* 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.
- */
+ for (found = 1; found != 0;
+ found = (*tclWinProcs->findNextFileProc)(handle, &data)) {
+ TCHAR *nativeMatchResult;
+ char *name;
- if (!matchDotFiles && (data.cFileName[0] == '.')) {
- continue;
+ if (tclWinProcs->useWide) {
+ nativeName = (TCHAR *) data.w.cFileName;
+ } else {
+ nativeName = (TCHAR *) data.a.cFileName;
}
+ name = Tcl_WinTCharToUtf(nativeName, -1, &ds);
/*
* Check to see if the file matches the pattern. We need to convert
@@ -286,21 +287,21 @@ TclMatchFiles(interp, separators, dirPtr, pattern, tail)
* 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 ((volFlags & FS_CASE_SENSITIVE) == 0) {
+ Tcl_UtfToLower(name);
}
- if (matchResult == NULL) {
+ nativeMatchResult = NULL;
+
+ if ((matchDotFiles == 0) && (name[0] == '.')) {
+ /*
+ * Ignore hidden files.
+ */
+ } else if (Tcl_StringMatch(name, newPattern) != 0) {
+ nativeMatchResult = nativeName;
+ }
+ Tcl_DStringFree(&ds);
+ if (nativeMatchResult == NULL) {
continue;
}
@@ -311,13 +312,22 @@ TclMatchFiles(interp, separators, dirPtr, pattern, tail)
* file to the result.
*/
- Tcl_DStringSetLength(dirPtr, baseLength);
- Tcl_DStringAppend(dirPtr, matchResult, -1);
+ name = Tcl_WinTCharToUtf(nativeMatchResult, -1, &ds);
+ if ((volFlags & FS_CASE_IS_PRESERVED) == 0) {
+ Tcl_UtfToLower(name);
+ }
+ Tcl_DStringAppend(dirPtr, name, -1);
+ Tcl_DStringFree(&ds);
+
if (tail == NULL) {
- Tcl_AppendElement(interp, dirPtr->string);
+ Tcl_AppendElement(interp, Tcl_DStringValue(dirPtr));
} else {
- atts = GetFileAttributes(dirPtr->string);
- if (atts & FILE_ATTRIBUTE_DIRECTORY) {
+ nativeName = Tcl_WinUtfToTChar(Tcl_DStringValue(dirPtr),
+ Tcl_DStringLength(dirPtr), &ds);
+ attr = (*tclWinProcs->getFileAttributesProc)(nativeName);
+ Tcl_DStringFree(&ds);
+
+ if (attr & FILE_ATTRIBUTE_DIRECTORY) {
Tcl_DStringAppend(dirPtr, "/", 1);
result = TclDoGlob(interp, separators, dirPtr, tail);
if (result != TCL_OK) {
@@ -325,211 +335,353 @@ TclMatchFiles(interp, separators, dirPtr, pattern, tail)
}
}
}
+ Tcl_DStringSetLength(dirPtr, dirLength);
}
- Tcl_DStringFree(&buffer);
FindClose(handle);
- ckfree(newPattern);
+ Tcl_DStringFree(&dirString);
+ Tcl_DStringFree(&patternString);
+
return result;
+
+ error:
+ Tcl_DStringFree(&dirString);
+ TclWinConvertError(GetLastError());
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, message, Tcl_DStringValue(dirPtr), "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
+ return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
- * TclChdir --
+ * TclpGetUserHome --
*
- * Change the current working directory.
+ * This function takes the passed in user name and finds the
+ * corresponding home directory specified in the password file.
*
* 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.
+ * The result is a pointer to a string specifying the user's home
+ * directory, or NULL if the user's home directory could not be
+ * determined. Storage for the result string is allocated in
+ * bufferPtr; the caller must call Tcl_DStringFree() when the result
+ * is no longer needed.
*
* Side effects:
- * The working directory for this application is changed. Also
- * the cache maintained used by TclGetCwd is deallocated and
- * set to NULL.
+ * None.
*
*----------------------------------------------------------------------
*/
-int
-TclChdir(interp, dirName)
- Tcl_Interp *interp; /* If non NULL, used for error reporting. */
- char *dirName; /* Path to new working directory. */
+char *
+TclpGetUserHome(name, bufferPtr)
+ CONST char *name; /* User name for desired home directory. */
+ Tcl_DString *bufferPtr; /* Uninitialized or free DString filled
+ * with name of user's home directory. */
{
- if (currentDir != NULL) {
- ckfree(currentDir);
- currentDir = NULL;
+ char *result;
+ HINSTANCE netapiInst;
+
+ result = NULL;
+
+ Tcl_DStringInit(bufferPtr);
+
+ netapiInst = LoadLibraryA("netapi32.dll");
+ if (netapiInst != NULL) {
+ NETAPIBUFFERFREEPROC *netApiBufferFreeProc;
+ NETGETDCNAMEPROC *netGetDCNameProc;
+ NETUSERGETINFOPROC *netUserGetInfoProc;
+
+ netApiBufferFreeProc = (NETAPIBUFFERFREEPROC *)
+ GetProcAddress(netapiInst, "NetApiBufferFree");
+ netGetDCNameProc = (NETGETDCNAMEPROC *)
+ GetProcAddress(netapiInst, "NetGetDCName");
+ netUserGetInfoProc = (NETUSERGETINFOPROC *)
+ GetProcAddress(netapiInst, "NetUserGetInfo");
+ if ((netUserGetInfoProc != NULL) && (netGetDCNameProc != NULL)
+ && (netApiBufferFreeProc != NULL)) {
+ USER_INFO_1 *uiPtr;
+ Tcl_DString ds;
+ int nameLen, badDomain;
+ char *domain;
+ WCHAR *wName, *wHomeDir, *wDomain;
+ WCHAR buf[MAX_PATH];
+
+ badDomain = 0;
+ nameLen = -1;
+ wDomain = NULL;
+ domain = strchr(name, '@');
+ if (domain != NULL) {
+ Tcl_DStringInit(&ds);
+ wName = TclUtfToUniCharDString(domain + 1, -1, &ds);
+ badDomain = (*netGetDCNameProc)(NULL, wName,
+ (LPBYTE *) &wDomain);
+ Tcl_DStringFree(&ds);
+ nameLen = domain - name;
+ }
+ if (badDomain == 0) {
+ Tcl_DStringInit(&ds);
+ wName = TclUtfToUniCharDString(name, nameLen, &ds);
+ if ((*netUserGetInfoProc)(wDomain, wName, 1,
+ (LPBYTE *) &uiPtr) == 0) {
+ wHomeDir = uiPtr->usri1_home_dir;
+ if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) {
+ TclUniCharToUtfDString(wHomeDir, lstrlenW(wHomeDir),
+ bufferPtr);
+ } else {
+ /*
+ * User exists but has no home dir. Return
+ * "{Windows Drive}:/users/default".
+ */
+
+ GetWindowsDirectoryW(buf, MAX_PATH);
+ TclUniCharToUtfDString(buf, 2, bufferPtr);
+ Tcl_DStringAppend(bufferPtr, "/users/default", -1);
+ }
+ result = Tcl_DStringValue(bufferPtr);
+ (*netApiBufferFreeProc)((void *) uiPtr);
+ }
+ Tcl_DStringFree(&ds);
+ }
+ if (wDomain != NULL) {
+ (*netApiBufferFreeProc)((void *) wDomain);
+ }
+ }
+ FreeLibrary(netapiInst);
}
- if (!SetCurrentDirectory(dirName)) {
- TclWinConvertError(GetLastError());
- if (interp != NULL) {
- Tcl_AppendResult(interp, "couldn't change working directory to \"",
- dirName, "\": ", Tcl_PosixError(interp), (char *) NULL);
+ if (result == NULL) {
+ /*
+ * Look in the "Password Lists" section of system.ini for the
+ * local user. There are also entries in that section that begin
+ * with a "*" character that are used by Windows for other
+ * purposes; ignore user names beginning with a "*".
+ */
+
+ char buf[MAX_PATH];
+
+ if (name[0] != '*') {
+ if (GetPrivateProfileStringA("Password Lists", name, "", buf,
+ MAX_PATH, "system.ini") > 0) {
+ /*
+ * User exists, but there is no such thing as a home
+ * directory in system.ini. Return "{Windows drive}:/".
+ */
+
+ GetWindowsDirectoryA(buf, MAX_PATH);
+ Tcl_DStringAppend(bufferPtr, buf, 3);
+ result = Tcl_DStringValue(bufferPtr);
+ }
}
- return TCL_ERROR;
}
- return TCL_OK;
+
+ return result;
}
/*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*
- * TclGetCwd --
+ * TclpAccess --
*
- * Return the path name of the current working directory.
+ * This function replaces the library version of access(), fixing the
+ * following bugs:
+ *
+ * 1. access() returns that all files have execute permission.
*
* 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.
+ * See access documentation.
*
* 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.
+ * See access documentation.
*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*/
-char *
-TclGetCwd(interp)
- Tcl_Interp *interp; /* If non NULL, used for error reporting. */
+int
+TclpAccess(
+ CONST char *path, /* Path of file to access (UTF-8). */
+ int mode) /* Permission setting. */
{
- 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;
- }
+ Tcl_DString ds;
+ TCHAR *nativePath;
+ DWORD attr;
+
+ nativePath = Tcl_WinUtfToTChar(path, -1, &ds);
+ attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
+ Tcl_DStringFree(&ds);
+
+ if (attr == 0xffffffff) {
/*
- * Watch for the wierd Windows '95 c:\\UNC syntax.
+ * File doesn't exist.
*/
- if (buffer[0] != '\0' && buffer[1] == ':' && buffer[2] == '\\'
- && buffer[3] == '\\') {
- bufPtr = &buffer[2];
- } else {
- bufPtr = buffer;
- }
+ TclWinConvertError(GetLastError());
+ return -1;
+ }
+ if ((mode & W_OK) && (attr & FILE_ATTRIBUTE_READONLY)) {
/*
- * Convert to forward slashes for easier use in scripts.
+ * File is not writable.
*/
- for (p = bufPtr; *p != '\0'; p++) {
- if (*p == '\\') {
- *p = '/';
+ Tcl_SetErrno(EACCES);
+ return -1;
+ }
+
+ if (mode & X_OK) {
+ CONST char *p;
+
+ if (attr & FILE_ATTRIBUTE_DIRECTORY) {
+ /*
+ * Directories are always executable.
+ */
+
+ return 0;
+ }
+ p = strrchr(path, '.');
+ if (p != NULL) {
+ p++;
+ if ((stricmp(p, "exe") == 0)
+ || (stricmp(p, "com") == 0)
+ || (stricmp(p, "bat") == 0)) {
+ /*
+ * File that ends with .exe, .com, or .bat is executable.
+ */
+
+ return 0;
}
}
+ Tcl_SetErrno(EACCES);
+ return -1;
}
- return bufPtr;
+
+ return 0;
}
-#if 0
/*
- *-------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*
- * TclWinResolveShortcut --
+ * TclpChdir --
*
- * Resolve a potential Windows shortcut to get the actual file or
- * directory in question.
+ * This function replaces the library version of chdir().
*
* 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.
+ * See chdir() documentation.
*
* Side effects:
- * Loads and unloads OLE package to determine if filename refers to
- * a shortcut.
+ * See chdir() documentation.
*
- *-------------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
int
-TclWinResolveShortcut(bufferPtr)
- Tcl_DString *bufferPtr; /* Holds name of file to resolve. On
- * return, holds resolved file name. */
+TclpChdir(path)
+ CONST char *path; /* Path to new working directory (UTF-8). */
{
- HRESULT hres;
- IShellLink *psl;
- IPersistFile *ppf;
- WIN32_FIND_DATA wfd;
- WCHAR wpath[MAX_PATH];
- char *path, *ext;
- char realFileName[MAX_PATH];
+ int result;
+ Tcl_DString ds;
+ TCHAR *nativePath;
+
+ nativePath = Tcl_WinUtfToTChar(path, -1, &ds);
+ result = (*tclWinProcs->setCurrentDirectoryProc)(nativePath);
+ Tcl_DStringFree(&ds);
+
+ if (result == 0) {
+ TclWinConvertError(GetLastError());
+ return -1;
+ }
+ return 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpGetCwd --
+ *
+ * This function replaces the library version of getcwd().
+ *
+ * Results:
+ * The result is a pointer to a string specifying the current
+ * directory, or NULL if the current directory could not be
+ * determined. If NULL is returned, an error message is left in the
+ * interp's result. Storage for the result string is allocated in
+ * bufferPtr; the caller must call Tcl_DStringFree() when the result
+ * is no longer needed.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+TclpGetCwd(interp, bufferPtr)
+ Tcl_Interp *interp; /* If non-NULL, used for error reporting. */
+ Tcl_DString *bufferPtr; /* Uninitialized or free DString filled
+ * with name of current directory. */
+{
+ WCHAR buffer[MAX_PATH];
+ char *p;
+
+ if ((*tclWinProcs->getCurrentDirectoryProc)(MAX_PATH, buffer) == 0) {
+ TclWinConvertError(GetLastError());
+ if (interp != NULL) {
+ Tcl_AppendResult(interp,
+ "error getting working directory name: ",
+ Tcl_PosixError(interp), (char *) NULL);
+ }
+ return NULL;
+ }
/*
- * Windows system calls do not automatically resolve
- * shortcuts like UNIX automatically will with symbolic links.
+ * Watch for the wierd Windows c:\\UNC syntax.
*/
- path = Tcl_DStringValue(bufferPtr);
- ext = strrchr(path, '.');
- if ((ext == NULL) || (stricmp(ext, ".lnk") != 0)) {
- return 0;
- }
+ if (tclWinProcs->useWide) {
+ WCHAR *native;
- 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();
+ native = (WCHAR *) buffer;
+ if ((native[0] != '\0') && (native[1] == ':')
+ && (native[2] == '\\') && (native[3] == '\\')) {
+ native += 2;
+ }
+ Tcl_WinTCharToUtf((TCHAR *) native, -1, bufferPtr);
+ } else {
+ char *native;
- if (realFileName[0] != '\0') {
- Tcl_DStringSetLength(bufferPtr, 0);
- Tcl_DStringAppend(bufferPtr, realFileName, -1);
- return 1;
+ native = (char *) buffer;
+ if ((native[0] != '\0') && (native[1] == ':')
+ && (native[2] == '\\') && (native[3] == '\\')) {
+ native += 2;
+ }
+ Tcl_WinTCharToUtf((TCHAR *) native, -1, bufferPtr);
}
- return 0;
+
+ /*
+ * Convert to forward slashes for easier use in scripts.
+ */
+
+ for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) {
+ if (*p == '\\') {
+ *p = '/';
+ }
+ }
+ return Tcl_DStringValue(bufferPtr);
}
-#endif
/*
*----------------------------------------------------------------------
*
- * TclWinStat, TclWinLstat --
+ * TclpStat --
*
- * These functions replace the library versions of stat and lstat.
+ * This function replaces the library version of stat(), fixing
+ * the following bugs:
*
- * 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.
+ * 1. stat("c:") returns an error.
+ * 2. Borland stat() return time in GMT instead of localtime.
+ * 3. stat("\\server\mount") would return error.
+ * 4. Accepts slashes or backslashes.
+ * 5. st_dev and st_rdev were wrong for UNC paths.
*
* Results:
* See stat documentation.
@@ -541,25 +693,164 @@ TclWinResolveShortcut(bufferPtr)
*/
int
-TclWinStat(path, buf)
- CONST char *path; /* Path of file to stat (in current CP). */
- struct stat *buf; /* Filled with results of stat call. */
+TclpStat(path, statPtr)
+ CONST char *path; /* Path of file to stat (UTF-8). */
+ struct stat *statPtr; /* Filled with results of stat call. */
{
- char name[4];
- int result;
+ Tcl_DString ds;
+ TCHAR *nativePath;
+ WIN32_FIND_DATAT data;
+ HANDLE handle;
+ DWORD attr;
+ WCHAR nativeFullPath[MAX_PATH];
+ TCHAR *nativePart;
+ char *p, *fullPath;
+ int dev, mode;
- if ((strlen(path) == 2) && (path[1] == ':')) {
- strcpy(name, path);
- name[2] = '.';
- name[3] = '\0';
- path = name;
+ /*
+ * Eliminate file names containing wildcard characters, or subsequent
+ * call to FindFirstFile() will expand them, matching some other file.
+ */
+
+ if (strpbrk(path, "?*") != NULL) {
+ Tcl_SetErrno(ENOENT);
+ return -1;
}
-#undef stat
+ nativePath = Tcl_WinUtfToTChar(path, -1, &ds);
+ handle = (*tclWinProcs->findFirstFileProc)(nativePath, &data);
+ if (handle == INVALID_HANDLE_VALUE) {
+ /*
+ * FindFirstFile() doesn't work on root directories, so call
+ * GetFileAttributes() to see if the specified file exists.
+ */
- result = stat(path, buf);
+ attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
+ if (attr == 0xffffffff) {
+ Tcl_DStringFree(&ds);
+ Tcl_SetErrno(ENOENT);
+ return -1;
+ }
+
+ /*
+ * Make up some fake information for this file. It has the
+ * correct file attributes and a time of 0.
+ */
+
+ memset(&data, 0, sizeof(data));
+ data.a.dwFileAttributes = attr;
+ } else {
+ FindClose(handle);
+ }
+
+ (*tclWinProcs->getFullPathNameProc)(nativePath, MAX_PATH, nativeFullPath,
+ &nativePart);
+
+ Tcl_DStringFree(&ds);
+ fullPath = Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds);
+
+ dev = -1;
+ if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) {
+ char *p;
+ DWORD dw;
+ TCHAR *nativeVol;
+ Tcl_DString volString;
+
+ p = strchr(fullPath + 2, '\\');
+ p = strchr(p + 1, '\\');
+ if (p == NULL) {
+ /*
+ * Add terminating backslash to fullpath or
+ * GetVolumeInformation() won't work.
+ */
+
+ fullPath = Tcl_DStringAppend(&ds, "\\", 1);
+ p = fullPath + Tcl_DStringLength(&ds);
+ } else {
+ p++;
+ }
+ nativeVol = Tcl_WinUtfToTChar(fullPath, p - fullPath, &volString);
+ dw = (DWORD) -1;
+ (*tclWinProcs->getVolumeInformationProc)(nativeVol, NULL, 0, &dw,
+ NULL, NULL, NULL, 0);
+ /*
+ * GetFullPathName() turns special devices like "NUL" into "\\.\NUL",
+ * but GetVolumeInformation() returns failure for "\\.\NUL". This
+ * will cause "NUL" to get a drive number of -1, which makes about
+ * as much sense as anything since the special devices don't live on
+ * any drive.
+ */
+
+ dev = dw;
+ Tcl_DStringFree(&volString);
+ } else if ((fullPath[0] != '\0') && (fullPath[1] == ':')) {
+ dev = Tcl_UniCharToLower(fullPath[0]) - 'a';
+ }
+ Tcl_DStringFree(&ds);
+
+ attr = data.a.dwFileAttributes;
+ mode = (attr & FILE_ATTRIBUTE_DIRECTORY) ? S_IFDIR | S_IEXEC : S_IFREG;
+ mode |= (attr & FILE_ATTRIBUTE_READONLY) ? S_IREAD : S_IREAD | S_IWRITE;
+ p = strrchr(path, '.');
+ if (p != NULL) {
+ if ((lstrcmpiA(p, ".exe") == 0)
+ || (lstrcmpiA(p, ".com") == 0)
+ || (lstrcmpiA(p, ".bat") == 0)
+ || (lstrcmpiA(p, ".pif") == 0)) {
+ mode |= S_IEXEC;
+ }
+ }
+
+ /*
+ * Propagate the S_IREAD, S_IWRITE, S_IEXEC bits to the group and
+ * other positions.
+ */
+
+ mode |= (mode & 0x0700) >> 3;
+ mode |= (mode & 0x0700) >> 6;
+
+ statPtr->st_dev = (dev_t) dev;
+ statPtr->st_ino = 0;
+ statPtr->st_mode = (unsigned short) mode;
+ statPtr->st_nlink = 1;
+ statPtr->st_uid = 0;
+ statPtr->st_gid = 0;
+ statPtr->st_rdev = (dev_t) dev;
+ statPtr->st_size = data.a.nFileSizeLow;
+ statPtr->st_atime = ToCTime(data.a.ftLastAccessTime);
+ statPtr->st_mtime = ToCTime(data.a.ftLastWriteTime);
+ statPtr->st_ctime = ToCTime(data.a.ftCreationTime);
+ return 0;
+}
+
+static time_t
+ToCTime(
+ FILETIME fileTime) /* UTC Time to convert to local time_t. */
+{
+ FILETIME localFileTime;
+ SYSTEMTIME systemTime;
+ struct tm tm;
-#ifndef _MSC_VER
+ if (FileTimeToLocalFileTime(&fileTime, &localFileTime) == 0) {
+ return 0;
+ }
+ if (FileTimeToSystemTime(&localFileTime, &systemTime) == 0) {
+ return 0;
+ }
+ tm.tm_sec = systemTime.wSecond;
+ tm.tm_min = systemTime.wMinute;
+ tm.tm_hour = systemTime.wHour;
+ tm.tm_mday = systemTime.wDay;
+ tm.tm_mon = systemTime.wMonth - 1;
+ tm.tm_year = systemTime.wYear - 1900;
+ tm.tm_wday = 0;
+ tm.tm_yday = 0;
+ tm.tm_isdst = -1;
+
+ return mktime(&tm);
+}
+
+#if 0
/*
* Borland's stat doesn't take into account localtime.
@@ -582,66 +873,83 @@ TclWinStat(path, buf)
#endif
- return result;
-}
-
+
+#if 0
/*
- *---------------------------------------------------------------------------
- *
- * TclWinAccess --
+ *-------------------------------------------------------------------------
*
- * This function replaces the library version of access.
+ * TclWinResolveShortcut --
*
- * The library version of access returns that all files have execute
- * permission.
+ * Resolve a potential Windows shortcut to get the actual file or
+ * directory in question.
*
* Results:
- * See access documentation.
+ * 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:
- * See access documentation.
+ * Loads and unloads OLE package to determine if filename refers to
+ * a shortcut.
*
- *---------------------------------------------------------------------------
+ *-------------------------------------------------------------------------
*/
int
-TclWinAccess(
- CONST char *path, /* Path of file to access (in current CP). */
- int mode) /* Permission setting. */
+TclWinResolveShortcut(bufferPtr)
+ Tcl_DString *bufferPtr; /* Holds name of file to resolve. On
+ * return, holds resolved file name. */
{
- int result;
- CONST char *p;
+ HRESULT hres;
+ IShellLink *psl;
+ IPersistFile *ppf;
+ WIN32_FIND_DATA wfd;
+ WCHAR wpath[MAX_PATH];
+ char *path, *ext;
+ char realFileName[MAX_PATH];
-#undef access
+ /*
+ * Windows system calls do not automatically resolve
+ * shortcuts like UNIX automatically will with symbolic links.
+ */
- result = access(path, mode);
+ path = Tcl_DStringValue(bufferPtr);
+ ext = strrchr(path, '.');
+ if ((ext == NULL) || (stricmp(ext, ".lnk") != 0)) {
+ return 0;
+ }
- if (result == 0) {
- if (mode & 1) {
- if (GetFileAttributes(path) & FILE_ATTRIBUTE_DIRECTORY) {
- /*
- * Directories are always executable.
- */
+ 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();
- 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;
- }
+ if (realFileName[0] != '\0') {
+ Tcl_DStringSetLength(bufferPtr, 0);
+ Tcl_DStringAppend(bufferPtr, realFileName, -1);
+ return 1;
}
- return result;
+ return 0;
}
-
+#endif
+
diff --git a/win/tclWinInit.c b/win/tclWinInit.c
index be8dbbd..98eda3f 100644
--- a/win/tclWinInit.c
+++ b/win/tclWinInit.c
@@ -3,16 +3,15 @@
*
* Contains the Windows-specific interpreter initialization functions.
*
- * Copyright (c) 1994-1996 Sun Microsystems, Inc.
+ * 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: @(#) tclWinInit.c 1.32 97/06/24 17:28:26
+ * SCCS: @(#) tclWinInit.c 1.48 98/02/17 17:17:19
*/
-#include "tclInt.h"
-#include "tclPort.h"
+#include "tclWinInt.h"
#include <winreg.h>
#include <winnt.h>
#include <winbase.h>
@@ -66,174 +65,432 @@ static char* processors[NUMPROCESSORS] = {
};
/*
- * 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.
+ * The Init script (common to Windows and Unix platforms) is
+ * defined in tkInitScript.h
*/
+#include "tclInitScript.h"
+
+
+static void AppendEnvironment(Tcl_Obj *listPtr, CONST char *lib);
+static void AppendPath(Tcl_Obj *listPtr, HMODULE hModule,
+ CONST char *lib);
+static void AppendRegistry(Tcl_Obj *listPtr, CONST char *lib);
+static int ToUtf(CONST WCHAR *wSrc, char *dst);
+
-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";
/*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
+ *
+ * TclpInitPlatform --
*
- * TclPlatformInit --
+ * Initialize all the platform-dependant things like signals and
+ * floating-point error handling.
*
- * Performs Windows-specific interpreter initialization related to the
- * tcl_library variable. Also sets up the HOME environment variable
- * if it is not already set.
+ * Called at process initialization time.
*
* Results:
* None.
*
* Side effects:
- * Sets "tcl_library" and "env(HOME)" Tcl variables
+ * None.
*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*/
void
-TclPlatformInit(interp)
- Tcl_Interp *interp;
+TclpInitPlatform()
{
- 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);
+ /*
+ * The following code stops Windows 3.X and Windows NT 3.51 from
+ * automatically putting up Sharing Violation dialogs, e.g, when
+ * someone tries to access a file that is locked or a drive with no
+ * disk in it. Tcl already returns the appropriate error to the
+ * caller, and they can decide to put up their own dialog in response
+ * to that failure.
+ *
+ * Under 95 and NT 4.0, this is a NOOP because the system doesn't
+ * automatically put up dialogs when the above operations fail.
+ */
+
+ SetErrorMode(SetErrorMode(0) | SEM_FAILCRITICALERRORS);
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclpInitLibraryPath --
+ *
+ * Initialize the library path at startup.
+ *
+ * This call sets the library path to strings in UTF-8. Any
+ * pre-existing library path information is assumed to have been
+ * in the native multibyte encoding.
+ *
+ * Called at process initialization time.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+void
+TclpInitLibraryPath(argv0)
+ CONST char *argv0; /* Name of executable from argv[0] to main().
+ * Not used because we can determine the name
+ * by querying the module handle. */
+{
+#define LIBRARY_SIZE 32
+ Tcl_Obj *pathPtr, *objPtr;
+ char installLib[LIBRARY_SIZE], developLib[LIBRARY_SIZE];
+
+ pathPtr = Tcl_NewObj();
/*
- * Find out what kind of system we are running on.
+ * set installLib lib/tcl[info tclversion]
+ *
+ * if {[string match {*[ab]*} [info patchlevel]} {
+ * set developLib ../tcl[info patchlevel]/library
+ * } else {
+ * set developLib ../tcl[info tclversion]/library
+ * }
*/
+
+ sprintf(installLib, "lib/tcl%s", TCL_VERSION);
+ sprintf(developLib, "../tcl%s/library",
+ ((TCL_RELEASE_LEVEL < 2) ? TCL_PATCH_LEVEL : TCL_VERSION));
- osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
- GetVersionEx(&osInfo);
+ /*
+ * if {[info exists $env(TCL_LIBRARY)]} {
+ * lappend dirs $env(TCL_LIBRARY)
+ * set split [file split $TCL_LIBRARY]
+ * set tail [lindex [file split $installLib] end]
+ * if {[string tolower [lindex $split end]] != $tail} {
+ * set split [lreplace $split end end $tail]
+ * lappend dirs [eval file join $split]
+ * }
+ * }
+ */
- isWin32s = (osInfo.dwPlatformId == VER_PLATFORM_WIN32s);
+ AppendEnvironment(pathPtr, installLib);
/*
- * Since Win32s doesn't support GetSystemInfo, we use a default value.
+ * if {[info exists $auto_path]} {
+ * eval lappend dirs $auto_path
+ * }
*/
- oemId = (OemId *) &sysInfo;
- if (!isWin32s) {
- GetSystemInfo(&sysInfo);
+ objPtr = TclGetLibraryPath();
+ if (objPtr != NULL) {
+ int objc;
+ Tcl_Obj **objv;
+ int i, length;
+ char *str;
+ char tmp[MAX_PATH * TCL_UTF_MAX];
+ WCHAR wBuf[MAX_PATH];
+
+ objc = 0;
+ Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv);
+ for (i = 0; i < objc; i++) {
+ str = Tcl_GetStringFromObj(objv[i], &length);
+ length = MultiByteToWideChar(CP_ACP, 0, str, length, wBuf,
+ MAX_PATH);
+ Tcl_SetStringObj(objv[i], tmp, ToUtf(wBuf, tmp));
+ }
+ Tcl_ListObjAppendList(NULL, pathPtr, objPtr);
+ }
+
+ /*
+ * if {[info nameofexecutable] != ""} {
+ * set prefix [file dirname [file dirname [info nameofexecutable]]]
+ * lappend dirs $prefix/$installLib
+ * lappend dirs $prefix/$developLib
+ * }
+ */
+
+ AppendPath(pathPtr, NULL, installLib);
+ AppendPath(pathPtr, NULL, developLib);
+ AppendPath(pathPtr, NULL, NULL);
+
+ /*
+ * if {[info nameoflibrary] != ""} {
+ * lappend dirs [file dirname [info nameoflibrary]]/$installLib
+ * }
+ */
+
+ AppendPath(pathPtr, TclWinGetTclInstance(), installLib);
+ AppendPath(pathPtr, TclWinGetTclInstance(), NULL);
+
+ AppendRegistry(pathPtr, installLib);
+ TclSetLibraryPath(pathPtr);
+}
+
+static void
+AppendEnvironment(
+ Tcl_Obj *listPtr,
+ CONST char *lib)
+{
+ int pathc;
+ WCHAR wBuf[MAX_PATH];
+ char buf[MAX_PATH * TCL_UTF_MAX];
+ Tcl_Obj *objPtr;
+ char *str;
+ Tcl_DString ds;
+ char **pathv;
+
+ if (GetEnvironmentVariableW(L"TCL_LIBRARY", wBuf, MAX_PATH) == 0) {
+ buf[0] = '\0';
+ GetEnvironmentVariableA("TCL_LIBRARY", buf, MAX_PATH);
} else {
- oemId->wProcessorArchitecture = PROCESSOR_ARCHITECTURE_INTEL;
+ ToUtf(wBuf, buf);
+ }
+
+ if (buf[0] != '\0') {
+ objPtr = Tcl_NewStringObj(buf, -1);
+ Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
+
+ TclWinNoBackslash(buf);
+ Tcl_SplitPath(buf, &pathc, &pathv);
+
+ /*
+ * The lstrcmpi() will work even if pathv[pathc - 1] is random
+ * UTF-8 chars because I know lib is ascii.
+ */
+
+ if ((pathc > 0) && (lstrcmpiA(lib + 4, pathv[pathc - 1]) != 0)) {
+ /*
+ * TCL_LIBRARY is set but refers to a different tcl
+ * installation than the current version. Try fiddling with the
+ * specified directory to make it refer to this installation by
+ * removing the old "tclX.Y" and substituting the current
+ * version string.
+ */
+
+ pathv[pathc - 1] = (char *) (lib + 4);
+ Tcl_DStringInit(&ds);
+ str = Tcl_JoinPath(pathc, pathv, &ds);
+ objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&ds));
+ Tcl_DStringFree(&ds);
+ } else {
+ objPtr = Tcl_NewStringObj(buf, -1);
+ }
+ Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
+ ckfree((char *) pathv);
+ }
+}
+
+static void
+AppendPath(
+ Tcl_Obj *listPtr,
+ HMODULE hModule,
+ CONST char *lib)
+{
+ WCHAR wName[MAX_PATH + LIBRARY_SIZE];
+ char name[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX];
+
+ if (GetModuleFileNameW(hModule, wName, MAX_PATH) == 0) {
+ GetModuleFileNameA(hModule, name, MAX_PATH);
+ } else {
+ ToUtf(wName, name);
+ }
+ if (lib != NULL) {
+ char *end, *p;
+
+ end = strrchr(name, '\\');
+ *end = '\0';
+ p = strrchr(name, '\\');
+ if (p != NULL) {
+ end = p;
+ }
+ *end = '\\';
+ strcpy(end + 1, lib);
+ }
+ TclWinNoBackslash(name);
+ Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewStringObj(name, -1));
+}
+
+static void
+AppendRegistry(
+ Tcl_Obj *listPtr,
+ CONST char *lib)
+{
+ HKEY key;
+ char *subKey;
+ LONG result;
+ WCHAR wBuf[MAX_PATH + 64];
+ char buf[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX];
+ DWORD len;
+
+ if (TclWinGetPlatformId() == VER_PLATFORM_WIN32s) {
+ key = HKEY_CLASSES_ROOT;
+ subKey = "";
+ } else {
+ key = HKEY_LOCAL_MACHINE;
+ subKey = "Root";
+ }
+ result = RegOpenKeyExA(key, "Software\\Sun\\Tcl\\" TCL_VERSION, 0,
+ KEY_QUERY_VALUE, &key);
+ if (result != ERROR_SUCCESS) {
+ return;
}
/*
- * Initialize the tcl_library variable from the registry.
+ * Can't just call RegQueryValueExW() and then if that fails (on 95)
+ * call RegQueryValueExA() because RegQueryValueExW() always seems to
+ * return ERROR_SUCCESS on Windows 95 even though it doesn't exist and
+ * doesn't do anything.
*/
- 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);
+ len = MAX_PATH;
+ if (TclWinGetPlatformId() == VER_PLATFORM_WIN32_NT) {
+ MultiByteToWideChar(CP_ACP, 0, subKey, -1, wBuf, MAX_PATH);
+ result = RegQueryValueExW(key, wBuf, NULL, NULL, (LPBYTE) wBuf, &len);
+ if (result == ERROR_SUCCESS) {
+ len = ToUtf(wBuf, buf);
}
} 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);
+ result = RegQueryValueExA(key, subKey, NULL, NULL, (LPBYTE) buf, &len);
+ }
+ if (result == ERROR_SUCCESS) {
+ if (buf[len - 1] != '\\') {
+ buf[len] = '\\';
+ len++;
}
+ strcpy(buf + len, lib);
+ TclWinNoBackslash(buf);
+ Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewStringObj(buf, -1));
}
- 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);
+ RegCloseKey(key);
+}
+
+static int
+ToUtf(
+ CONST WCHAR *wSrc,
+ char *dst)
+{
+ char *start;
+
+ start = dst;
+ while (*wSrc != '\0') {
+ dst += Tcl_UniCharToUtf(*wSrc, dst);
+ wSrc++;
+ }
+ *dst = '\0';
+ return dst - start;
+}
+
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclpSetInitialEncodings --
+ *
+ * Based on the locale, determine the encoding of the operating
+ * system and the default encoding for newly opened files.
+ *
+ * Called at process initialization time.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The Tcl library path is converted from native encoding to UTF-8.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+void
+TclpSetInitialEncodings()
+{
+ CONST char *encoding;
+ char buf[4 + TCL_INTEGER_SPACE];
+ int platformId;
+ Tcl_Obj *pathPtr;
+
+ platformId = TclWinGetPlatformId();
+
+ TclWinSetInterfaces(platformId == VER_PLATFORM_WIN32_NT);
+
+ wsprintfA(buf, "cp%d", GetACP());
+ Tcl_SetSystemEncoding(NULL, buf);
+
+ if (platformId != VER_PLATFORM_WIN32_NT) {
+ pathPtr = TclGetLibraryPath();
+ if (pathPtr != NULL) {
+ int i, objc;
+ Tcl_Obj **objv;
+
+ objc = 0;
+ Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv);
+ for (i = 0; i < objc; i++) {
+ int length;
+ char *string;
+ Tcl_DString ds;
+
+ string = Tcl_GetStringFromObj(objv[i], &length);
+ Tcl_ExternalToUtfDString(NULL, string, length, &ds);
+ Tcl_SetStringObj(objv[i], Tcl_DStringValue(&ds),
+ Tcl_DStringLength(&ds));
+ Tcl_DStringFree(&ds);
+ }
+ }
+ }
+
+ /*
+ * Keep this encoding preloaded. The IO package uses it for gets on a
+ * binary channel.
+ */
+
+ encoding = "iso8859-1";
+ Tcl_GetEncoding(NULL, encoding);
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclpSetVariables --
+ *
+ * Performs platform-specific interpreter initialization related to
+ * the tcl_library and tcl_platform variables, and other platform-
+ * specific things.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Sets "tcl_library", "tcl_platform", and "env(HOME)" Tcl variables.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpSetVariables(interp)
+ Tcl_Interp *interp; /* Interp to initialize. */
+{
+ char *ptr;
+ char buffer[TCL_INTEGER_SPACE * 2];
+ SYSTEM_INFO sysInfo;
+ OemId *oemId;
+ OSVERSIONINFOA osInfo;
+
+ osInfo.dwOSVersionInfoSize = sizeof(osInfo);
+ GetVersionExA(&osInfo);
+
+ oemId = (OemId *) &sysInfo;
+ if (osInfo.dwPlatformId == VER_PLATFORM_WIN32s) {
+ /*
+ * Since Win32s doesn't support GetSystemInfo, we use a default value.
+ */
+
+ oemId->wProcessorArchitecture = PROCESSOR_ARCHITECTURE_INTEL;
+ } else {
+ GetSystemInfo(&sysInfo);
}
/*
@@ -246,7 +503,7 @@ TclPlatformInit(interp)
Tcl_SetVar2(interp, "tcl_platform", "os",
platforms[osInfo.dwPlatformId], TCL_GLOBAL_ONLY);
}
- sprintf(buffer, "%d.%d", osInfo.dwMajorVersion, osInfo.dwMinorVersion);
+ wsprintfA(buffer, "%d.%d", osInfo.dwMajorVersion, osInfo.dwMinorVersion);
Tcl_SetVar2(interp, "tcl_platform", "osVersion", buffer, TCL_GLOBAL_ONLY);
if (oemId->wProcessorArchitecture < NUMPROCESSORS) {
Tcl_SetVar2(interp, "tcl_platform", "machine",
@@ -261,7 +518,9 @@ TclPlatformInit(interp)
ptr = Tcl_GetVar2(interp, "env", "HOME", TCL_GLOBAL_ONLY);
if (ptr == NULL) {
- Tcl_DStringSetLength(&ds, 0);
+ Tcl_DString ds;
+
+ Tcl_DStringInit(&ds);
ptr = Tcl_GetVar2(interp, "env", "HOMEDRIVE", TCL_GLOBAL_ONLY);
if (ptr != NULL) {
Tcl_DStringAppend(&ds, ptr, -1);
@@ -276,9 +535,8 @@ TclPlatformInit(interp)
} else {
Tcl_SetVar2(interp, "env", "HOME", "c:\\", TCL_GLOBAL_ONLY);
}
+ Tcl_DStringFree(&ds);
}
-
- Tcl_DStringFree(&ds);
}
/*
@@ -291,8 +549,8 @@ TclPlatformInit(interp)
* such as sourcing the "init.tcl" script.
*
* Results:
- * Returns a standard Tcl completion code and sets interp->result
- * if there is an error.
+ * Returns a standard Tcl completion code and sets the interp's
+ * result if there is an error.
*
* Side effects:
* Depends on what's in the init.tcl script.
@@ -304,31 +562,14 @@ int
Tcl_Init(interp)
Tcl_Interp *interp; /* Interpreter to initialize. */
{
- return Tcl_Eval(interp, initScript);
+ Tcl_Obj *pathPtr;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * 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;
+ pathPtr = TclGetLibraryPath();
+ if (pathPtr == NULL) {
+ pathPtr = Tcl_NewObj();
+ }
+ Tcl_SetObjVar2(interp, "tcl_libPath", NULL, pathPtr, TCL_GLOBAL_ONLY);
+ return Tcl_Eval(interp, initScript);
}
/*
@@ -383,8 +624,8 @@ Tcl_SourceRCFile(interp)
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_WriteObj(errChannel, Tcl_GetObjResult(interp));
+ Tcl_WriteChars(errChannel, "\n", 1);
}
}
}
diff --git a/win/tclWinInt.h b/win/tclWinInt.h
index 04e84d6..19d3fb6 100644
--- a/win/tclWinInt.h
+++ b/win/tclWinInt.h
@@ -8,7 +8,7 @@
* 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
+ * SCCS: @(#) tclWinInt.h 1.17 98/02/02 22:07:26
*/
#ifndef _TCLWININT
@@ -22,6 +22,14 @@
#endif
/*
+ * The following specifies how much stack space TclpCheckStackSpace()
+ * ensures is available. TclpCheckStackSpace() is called by Tcl_EvalObj()
+ * to help avoid overflowing the stack in the case of infinite recursion.
+ */
+
+#define TCL_WIN_STACK_THRESHOLD 0x2000
+
+/*
* Some versions of Borland C have a define for the OSVERSIONINFO for
* Win32s and for NT, but not for Windows 95.
*/
@@ -30,9 +38,69 @@
#define VER_PLATFORM_WIN32_WINDOWS 1
#endif
-EXTERN int TclWinSynchSpawn(void *args, int type, void **trans,
- Tcl_Pid *pidPtr);
+EXTERN void TclpAlertNotifier();
+EXTERN void TclpInitNotifier();
+/*
+ * The following structure keeps track of whether we are using the
+ * multi-byte or the wide-character interfaces to the operating system.
+ * System calls should be made through the following function table.
+ */
+
+typedef union {
+ WIN32_FIND_DATAA a;
+ WIN32_FIND_DATAW w;
+} WIN32_FIND_DATAT;
+
+typedef struct TclWinProcs {
+ int useWide;
+
+ BOOL (WINAPI *buildCommDCBProc)(CONST TCHAR *, LPDCB);
+ TCHAR *(WINAPI *charLowerProc)(TCHAR *);
+ BOOL (WINAPI *copyFileProc)(CONST TCHAR *, CONST TCHAR *, BOOL);
+ BOOL (WINAPI *createDirectoryProc)(CONST TCHAR *, LPSECURITY_ATTRIBUTES);
+ HANDLE (WINAPI *createFileProc)(CONST TCHAR *, DWORD, DWORD,
+ LPSECURITY_ATTRIBUTES, DWORD, DWORD, HANDLE);
+ BOOL (WINAPI *createProcessProc)(CONST TCHAR *, TCHAR *,
+ LPSECURITY_ATTRIBUTES, LPSECURITY_ATTRIBUTES, BOOL, DWORD,
+ LPVOID, CONST TCHAR *, LPSTARTUPINFOA, LPPROCESS_INFORMATION);
+ BOOL (WINAPI *deleteFileProc)(CONST TCHAR *);
+ HANDLE (WINAPI *findFirstFileProc)(CONST TCHAR *, WIN32_FIND_DATAT *);
+ BOOL (WINAPI *findNextFileProc)(HANDLE, WIN32_FIND_DATAT *);
+ BOOL (WINAPI *getComputerNameProc)(WCHAR *, LPDWORD);
+ DWORD (WINAPI *getCurrentDirectoryProc)(DWORD, WCHAR *);
+ DWORD (WINAPI *getFileAttributesProc)(CONST TCHAR *);
+ DWORD (WINAPI *getFullPathNameProc)(CONST TCHAR *, DWORD nBufferLength,
+ WCHAR *, TCHAR **);
+ DWORD (WINAPI *getModuleFileNameProc)(HMODULE, WCHAR *, int);
+ DWORD (WINAPI *getShortPathNameProc)(CONST TCHAR *, WCHAR *, DWORD);
+ UINT (WINAPI *getTempFileNameProc)(CONST TCHAR *, CONST TCHAR *, UINT,
+ WCHAR *);
+ DWORD (WINAPI *getTempPathProc)(DWORD, WCHAR *);
+ BOOL (WINAPI *getVolumeInformationProc)(CONST TCHAR *, WCHAR *, DWORD,
+ LPDWORD, LPDWORD, LPDWORD, WCHAR *, DWORD);
+ HINSTANCE (WINAPI *loadLibraryProc)(CONST TCHAR *);
+ TCHAR (WINAPI *lstrcpyProc)(WCHAR *, CONST TCHAR *);
+ BOOL (WINAPI *moveFileProc)(CONST TCHAR *, CONST TCHAR *);
+ BOOL (WINAPI *removeDirectoryProc)(CONST TCHAR *);
+ DWORD (WINAPI *searchPathProc)(CONST TCHAR *, CONST TCHAR *,
+ CONST TCHAR *, DWORD, WCHAR *, TCHAR **);
+ BOOL (WINAPI *setCurrentDirectoryProc)(CONST TCHAR *);
+ BOOL (WINAPI *setFileAttributesProc)(CONST TCHAR *, DWORD);
+} TclWinProcs;
+
+EXTERN TclWinProcs *tclWinProcs;
+EXTERN Tcl_Encoding tclWinTCharEncoding;
+
+EXTERN TclPlatformType *TclWinGetPlatform(void);
EXTERN int TclWinGetPlatformId(void);
+EXTERN char * TclWinNoBackslash(char *path);
+EXTERN void TclWinSetInterfaces(int);
+EXTERN int TclWinSynchSpawn(void *args, int type, void **trans,
+ Tcl_Pid *pidPtr);
+EXTERN TCHAR * Tcl_WinUtfToTChar(CONST char *string, int len,
+ Tcl_DString *dsPtr);
+EXTERN char * Tcl_WinTCharToUtf(CONST TCHAR *string, int len,
+ Tcl_DString *dsPtr);
#endif /* _TCLWININT */
diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c
index 8106671..b49cb1c 100644
--- a/win/tclWinLoad.c
+++ b/win/tclWinLoad.c
@@ -5,22 +5,21 @@
* works with the Windows "LoadLibrary" and "GetProcAddress"
* API for dynamic loading.
*
- * Copyright (c) 1995 Sun Microsystems, Inc.
+ * 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: @(#) tclWinLoad.c 1.6 96/02/15 11:54:07
+ * SCCS: @(#) tclWinLoad.c 1.10 98/01/20 22:42:13
*/
-#include "tclInt.h"
-#include "tclPort.h"
+#include "tclWinInt.h"
/*
*----------------------------------------------------------------------
*
- * TclLoadFile --
+ * TclpLoadFile --
*
* Dynamically loads a binary code file into memory and returns
* the addresses of two procedures within that file, if they
@@ -28,7 +27,7 @@
*
* Results:
* A standard Tcl completion code. If an error occurs, an error
- * message is left in interp->result.
+ * message is left in the interp's result.
*
* Side effects:
* New code suddenly appears in memory.
@@ -37,7 +36,7 @@
*/
int
-TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr)
+TclpLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr, clientDataPtr)
Tcl_Interp *interp; /* Used for error reporting. */
char *fileName; /* Name of the file containing the desired
* code. */
@@ -46,12 +45,22 @@ TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr)
Tcl_PackageInitProc **proc1Ptr, **proc2Ptr;
/* Where to return the addresses corresponding
* to sym1 and sym2. */
+ ClientData *clientDataPtr; /* Filled with token for dynamically loaded
+ * file which will be passed back to
+ * TclpUnloadFile() to unload the file. */
{
HINSTANCE handle;
- char *buffer;
+ TCHAR *nativeName;
+ Tcl_DString ds;
- handle = TclWinLoadLibrary(fileName);
+ nativeName = Tcl_WinUtfToTChar(fileName, -1, &ds);
+ handle = (*tclWinProcs->loadLibraryProc)(nativeName);
+ Tcl_DStringFree(&ds);
+
+ *clientDataPtr = (ClientData) handle;
+
if (handle == NULL) {
+ TclWinConvertError(GetLastError());
Tcl_AppendResult(interp, "couldn't load file \"", fileName,
"\": ", Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
@@ -64,28 +73,56 @@ TclLoadFile(interp, fileName, sym1, sym2, proc1Ptr, proc2Ptr)
*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);
+ Tcl_DStringAppend(&ds, "_", 1);
+ sym1 = Tcl_DStringAppend(&ds, sym1, -1);
+ *proc1Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, sym1);
+ Tcl_DStringFree(&ds);
}
*proc2Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, sym2);
if (*proc2Ptr == NULL) {
- buffer = ckalloc(strlen(sym2)+2);
- buffer[0] = '_';
- strcpy(buffer+1, sym2);
- *proc2Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, buffer);
- ckfree(buffer);
+ Tcl_DStringAppend(&ds, "_", 1);
+ sym2 = Tcl_DStringAppend(&ds, sym2, -1);
+ *proc2Ptr = (Tcl_PackageInitProc *) GetProcAddress(handle, sym2);
+ Tcl_DStringFree(&ds);
}
-
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
+ * TclpUnloadFile --
+ *
+ * Unloads a dynamically loaded binary code file from memory.
+ * Code pointers in the formerly loaded file are no longer valid
+ * after calling this function.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Code removed from memory.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpUnloadFile(clientData)
+ ClientData clientData; /* ClientData returned by a previous call
+ * to TclpLoadFile(). The clientData is
+ * a token that represents the loaded
+ * file. */
+{
+ HINSTANCE handle;
+
+ handle = (HINSTANCE) clientData;
+ FreeLibrary(handle);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclGuessPackageName --
*
* If the "load" command is invoked without providing a package
diff --git a/win/tclWinMtherr.c b/win/tclWinMtherr.c
index 98c528d..f630767 100644
--- a/win/tclWinMtherr.c
+++ b/win/tclWinMtherr.c
@@ -9,21 +9,12 @@
* 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
+ * SCCS: @(#) tclWinMtherr.c 1.4 98/02/13 15:35:39
*/
-#include "tclInt.h"
-#include "tclPort.h"
+#include "tclWinInt.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;
/*
*----------------------------------------------------------------------
@@ -49,7 +40,7 @@ int
_matherr(xPtr)
struct exception *xPtr; /* Describes error that occurred. */
{
- if (!tcl_MathInProgress) {
+ if (!TclMathInProgress()) {
return 0;
}
if ((xPtr->type == DOMAIN) || (xPtr->type == SING)) {
diff --git a/win/tclWinNotify.c b/win/tclWinNotify.c
index 8df95e3..99eb641 100644
--- a/win/tclWinNotify.c
+++ b/win/tclWinNotify.c
@@ -10,11 +10,10 @@
* 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
+ * SCCS: @(#) tclWinNotify.c 1.20 98/02/12 19:04:16
*/
-#include "tclInt.h"
-#include "tclPort.h"
+#include "tclWinInt.h"
#include <winsock.h>
/*
@@ -23,99 +22,192 @@
static int initialized = 0;
-#define INTERVAL_TIMER 1 /* Handle of interval timer. */
+#define INTERVAL_TIMER 1 /* Handle of interval timer. */
+#define WM_WAKEUP WM_USER /* Message that is send by
+ * TclpAlertNotifier. */
/*
* The following static structure contains the state information for the
- * Windows implementation of the Tcl notifier.
+ * Windows implementation of the Tcl notifier. One of these structures
+ * is created for each thread that is using the notifier.
*/
-static struct {
+typedef struct ThreadSpecificData {
+ CRITICAL_SECTION crit; /* Monitor for this notifier. */
+ int pending; /* Alert message pending, this field is
+ * locked by the notifierMutex. */
HWND hwnd; /* Messaging window. */
int timeout; /* Current timeout value. */
int timerActive; /* 1 if interval timer is running. */
-} notifier;
+} ThreadSpecificData;
+
+static Tcl_ThreadDataKey dataKey;
+
+/*
+ * The following static indicates the number of threads that have
+ * initialized notifiers.
+ *
+ * You must hold the notifierMutex lock before accessing this variable.
+ */
+
+static int notifierCount = 0;
+
+/*
+ * The notifierMutex locks access to all of the global notifier state,
+ * as well as the pending flag for any specific notifier.
+ */
+
+static Tcl_Mutex notifierMutex;
/*
* 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);
+static void UpdateTimer(ThreadSpecificData *tsdPtr, int timeout);
+
/*
*----------------------------------------------------------------------
*
- * InitNotifier --
+ * Tcl_InitNotifier --
*
- * Initializes the notifier window.
+ * Initializes the platform specific notifier state.
*
* Results:
- * None.
+ * Returns a handle to the notifier state for this thread..
*
* Side effects:
- * Creates a new notifier window and window class.
+ * None.
*
*----------------------------------------------------------------------
*/
-static void
-InitNotifier(void)
+ClientData
+Tcl_InitNotifier()
{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
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");
+ /*
+ * Register Notifier window class if this is the first thread to
+ * use this module.
+ */
+
+ Tcl_MutexLock(&notifierMutex);
+ if (notifierCount == 0) {
+ class.style = 0;
+ class.cbClsExtra = 0;
+ class.cbWndExtra = 0;
+ class.hInstance = TclWinGetTclInstance();
+ class.hbrBackground = NULL;
+ class.lpszMenuName = NULL;
+ class.lpszClassName = "TclNotifier";
+ class.lpfnWndProc = NotifierProc;
+ class.hIcon = NULL;
+ class.hCursor = NULL;
+
+ if (!RegisterClassA(&class)) {
+ panic("Unable to register TclNotifier window class");
+ }
}
- notifier.hwnd = CreateWindow("TclNotifier", "TclNotifier", WS_TILED,
+ notifierCount++;
+
+ tsdPtr->pending = 0;
+ tsdPtr->timerActive = 0;
+
+ /*
+ * Create a window for communication with the notifier.
+ */
+
+ tsdPtr->hwnd = CreateWindowA("TclNotifier", "TclNotifier", WS_TILED,
0, 0, 0, 0, NULL, NULL, TclWinGetTclInstance(), NULL);
- Tcl_CreateExitHandler(NotifierExitHandler, NULL);
+
+
+ Tcl_MutexUnlock(&notifierMutex);
+
+ return (ClientData) tsdPtr;
}
/*
*----------------------------------------------------------------------
*
- * NotifierExitHandler --
+ * Tcl_FinalizeNotifier --
*
* This function is called to cleanup the notifier state before
- * Tcl is unloaded.
+ * a thread is terminated.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * May dispose of the notifier window and class.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_FinalizeNotifier(clientData)
+ ClientData clientData; /* Pointer to notifier data. */
+{
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;
+
+ Tcl_MutexLock(&notifierMutex);
+
+ /*
+ * Clean up the timer and messaging window for this thread.
+ */
+
+ KillTimer(tsdPtr->hwnd, INTERVAL_TIMER);
+ DestroyWindow(tsdPtr->hwnd);
+
+ /*
+ * If this is the last thread to use the notifier, unregister
+ * the notifier window class.
+ */
+
+ notifierCount--;
+ if (notifierCount == 0) {
+ UnregisterClassA("TclNotifier", TclWinGetTclInstance());
+ }
+
+ Tcl_MutexUnlock(&notifierMutex);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_AlertNotifier --
+ *
+ * Wake up the specified notifier from any thread. This routine
+ * is called by the platform independent notifier code whenever
+ * the Tcl_ThreadAlert routine is called. This routine is
+ * guaranteed not to be called on a given notifier after
+ * Tcl_FinalizeNotifier is called for that notifier.
*
* Results:
* None.
*
* Side effects:
- * Destroys the notifier window.
+ * Sends a message to the messaging window for the notifier
+ * if there isn't already one pending.
*
*----------------------------------------------------------------------
*/
-static void
-NotifierExitHandler(
- ClientData clientData) /* Old window proc */
+void
+Tcl_AlertNotifier(clientData)
+ ClientData clientData; /* Pointer to thread data. */
{
- initialized = 0;
- if (notifier.hwnd) {
- KillTimer(notifier.hwnd, INTERVAL_TIMER);
- DestroyWindow(notifier.hwnd);
- UnregisterClass("TclNotifier", TclWinGetTclInstance());
- notifier.hwnd = NULL;
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;
+
+ Tcl_MutexLock(&notifierMutex);
+ if (!tsdPtr->pending) {
+ PostMessage(tsdPtr->hwnd, WM_WAKEUP, 0, 0);
+ tsdPtr->pending = 1;
}
+ Tcl_MutexUnlock(&notifierMutex);
}
/*
@@ -136,16 +228,17 @@ NotifierExitHandler(
void
UpdateTimer(
+ ThreadSpecificData *tsdPtr, /* Pointer to notifier state. */
int timeout) /* ms timeout, 0 means cancel timer */
{
- notifier.timeout = timeout;
+ tsdPtr->timeout = timeout;
if (timeout != 0) {
- notifier.timerActive = 1;
- SetTimer(notifier.hwnd, INTERVAL_TIMER,
- (unsigned long) notifier.timeout, NULL);
+ tsdPtr->timerActive = 1;
+ SetTimer(tsdPtr->hwnd, INTERVAL_TIMER,
+ (unsigned long) tsdPtr->timeout, NULL);
} else {
- notifier.timerActive = 0;
- KillTimer(notifier.hwnd, INTERVAL_TIMER);
+ tsdPtr->timerActive = 0;
+ KillTimer(tsdPtr->hwnd, INTERVAL_TIMER);
}
}
@@ -171,12 +264,9 @@ void
Tcl_SetTimer(
Tcl_Time *timePtr) /* Maximum block time, or NULL. */
{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
UINT timeout;
- if (!initialized) {
- InitNotifier();
- }
-
if (!timePtr) {
timeout = 0;
} else {
@@ -189,7 +279,7 @@ Tcl_SetTimer(
timeout = 1;
}
}
- UpdateTimer(timeout);
+ UpdateTimer(tsdPtr, timeout);
}
/*
@@ -197,8 +287,10 @@ Tcl_SetTimer(
*
* NotifierProc --
*
- * This procedure is invoked by Windows to process the timer
- * message whenever we are using an external dispatch loop.
+ * This procedure is invoked by Windows to process events on
+ * the notifier window. Messages will be sent to this window
+ * in response to external timer events or calls to
+ * TclpAlertTsdPtr->
*
* Results:
* A standard windows result.
@@ -216,8 +308,13 @@ NotifierProc(
WPARAM wParam,
LPARAM lParam)
{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- if (message != WM_TIMER) {
+ if (message == WM_USER) {
+ Tcl_MutexLock(&notifierMutex);
+ tsdPtr->pending = 0;
+ Tcl_MutexUnlock(&notifierMutex);
+ } else if (message != WM_TIMER) {
return DefWindowProc(hwnd, message, wParam, lParam);
}
@@ -253,13 +350,10 @@ int
Tcl_WaitForEvent(
Tcl_Time *timePtr) /* Maximum block time, or NULL. */
{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
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.
@@ -270,7 +364,7 @@ Tcl_WaitForEvent(
} else {
timeout = 0;
}
- UpdateTimer(timeout);
+ UpdateTimer(tsdPtr, timeout);
if (!timePtr || (timeout != 0)
|| PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE)) {
@@ -290,7 +384,7 @@ Tcl_WaitForEvent(
* claim to be doing work when we aren't.
*/
- if (msg.message == WM_TIMER && msg.hwnd == notifier.hwnd) {
+ if (msg.message == WM_TIMER && msg.hwnd == tsdPtr->hwnd) {
return 0;
}
diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c
index a7aeaf4..0c1d8a9 100644
--- a/win/tclWinPipe.c
+++ b/win/tclWinPipe.c
@@ -9,7 +9,7 @@
* 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
+ * SCCS: @(#) tclWinPipe.c 1.63 98/02/19 14:12:31
*/
#include "tclWinInt.h"
@@ -25,6 +25,7 @@
*/
static int initialized = 0;
+static Tcl_Mutex procMutex;
/*
* The following defines identify the various types of applications that
@@ -98,17 +99,25 @@ typedef struct ProcInfo {
static ProcInfo *procList;
/*
- * State flags used in the PipeInfo structure below.
+ * Bit masks used in the flags field of the PipeInfo structure below.
*/
#define PIPE_PENDING (1<<0) /* Message is pending in the queue. */
#define PIPE_ASYNC (1<<1) /* Channel is non-blocking. */
/*
+ * Bit masks used in the sharedFlags field of the PipeInfo structure below.
+ */
+
+#define PIPE_EOF (1<<2) /* Pipe has reached EOF. */
+#define PIPE_EXTRABYTE (1<<3) /* The reader thread has consumed one byte. */
+
+/*
* This structure describes per-instance data for a pipe based channel.
*/
typedef struct PipeInfo {
+ struct PipeInfo *nextPtr; /* Pointer to next registered pipe. */
Tcl_Channel channel; /* Pointer to channel structure. */
int validMask; /* OR'ed combination of TCL_READABLE,
* TCL_WRITABLE, or TCL_EXCEPTION: indicates
@@ -122,15 +131,56 @@ typedef struct PipeInfo {
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. */
+ Tcl_ThreadId threadId; /* Thread to which events should be reported.
+ * This value is used by the reader/writer
+ * threads. */
+ HANDLE writeThread; /* Handle to writer thread. */
+ HANDLE readThread; /* Handle to reader thread. */
+ HANDLE writable; /* Manual-reset event to signal when the
+ * writer thread has finished waiting for
+ * the current buffer to be written. */
+ HANDLE readable; /* Manual-reset event to signal when the
+ * reader thread has finished waiting for
+ * input. */
+ HANDLE startWriter; /* Auto-reset event used by the main thread to
+ * signal when the writer thread should attempt
+ * to write to the pipe. */
+ HANDLE startReader; /* Auto-reset event used by the main thread to
+ * signal when the reader thread should attempt
+ * to read from the pipe. */
+ DWORD writeError; /* An error caused by the last background
+ * write. Set to 0 if no error has been
+ * detected. This word is shared with the
+ * writer thread so access must be
+ * synchronized with the writable object.
+ */
+ char *writeBuf; /* Current background output buffer.
+ * Access is synchronized with the writable
+ * object. */
+ int writeBufLen; /* Size of write buffer. Access is
+ * synchronized with the writable
+ * object. */
+ int toWrite; /* Current amount to be written. Access is
+ * synchronized with the writable object. */
+ int readFlags; /* Flags that are shared with the reader
+ * thread. Access is synchronized with the
+ * readable object. */
+ char extraByte; /* Buffer for extra character consumed by
+ * reader thread. This byte is shared with
+ * the reader thread so access must be
+ * synchronized with the readable object. */
} PipeInfo;
-/*
- * The following pointer refers to the head of the list of pipes
- * that are being watched for file events.
- */
+typedef struct ThreadSpecificData {
+ /*
+ * The following pointer refers to the head of the list of pipes
+ * that are being watched for file events.
+ */
+
+ PipeInfo *firstPipePtr;
+} ThreadSpecificData;
-static PipeInfo *firstPipePtr;
+static Tcl_ThreadDataKey dataKey;
/*
* The following structure is what is added to the Tcl event queue when
@@ -150,30 +200,34 @@ typedef struct 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]);
+static int ApplicationType(Tcl_Interp *interp,
+ const char *fileName, char *fullName);
+static void BuildCommandLine(const char *executable, int argc,
+ char **argv, Tcl_DString *linePtr);
+static void CopyChannel(HANDLE dst, HANDLE src);
+static BOOL HasConsole(void);
+static TclFile MakeFile(HANDLE handle);
+static char * MakeTempFile(Tcl_DString *namePtr);
+static int PipeBlockModeProc(ClientData instanceData, int mode);
+static void PipeCheckProc(ClientData clientData, int flags);
+static int PipeClose2Proc(ClientData instanceData,
+ Tcl_Interp *interp, int flags);
+static int PipeEventProc(Tcl_Event *evPtr, int flags);
+static void PipeExitHandler(ClientData clientData);
+static int PipeGetHandleProc(ClientData instanceData,
+ int direction, ClientData *handlePtr);
+static void PipeInit(void);
+static int PipeInputProc(ClientData instanceData, char *buf,
+ int toRead, int *errorCode);
+static int PipeOutputProc(ClientData instanceData, char *buf,
+ int toWrite, int *errorCode);
+static DWORD WINAPI PipeReaderThread(LPVOID arg);
+static void PipeSetupProc(ClientData clientData, int flags);
+static void PipeWatchProc(ClientData instanceData, int mask);
+static DWORD WINAPI PipeWriterThread(LPVOID arg);
+static void ProcExitHandler(ClientData clientData);
+static int TempFileName(WCHAR name[MAX_PATH]);
+static int WaitForRead(PipeInfo *infoPtr, int blocking);
/*
* This structure describes the channel type structure for command pipe
@@ -183,7 +237,7 @@ static int TempFileName(char name[MAX_PATH]);
static Tcl_ChannelType pipeChannelType = {
"pipe", /* Type name. */
PipeBlockModeProc, /* Set blocking or non-blocking mode.*/
- PipeCloseProc, /* Close proc. */
+ TCL_CLOSE2PROC, /* Close proc. */
PipeInputProc, /* Input proc. */
PipeOutputProc, /* Output proc. */
NULL, /* Seek proc. */
@@ -191,6 +245,7 @@ static Tcl_ChannelType pipeChannelType = {
NULL, /* Get option proc. */
PipeWatchProc, /* Set up notifier to watch the channel. */
PipeGetHandleProc, /* Get an OS handle from channel. */
+ PipeClose2Proc
};
/*
@@ -212,11 +267,22 @@ static Tcl_ChannelType pipeChannelType = {
static void
PipeInit()
{
- initialized = 1;
- firstPipePtr = NULL;
- procList = NULL;
- Tcl_CreateEventSource(PipeSetupProc, PipeCheckProc, NULL);
- Tcl_CreateExitHandler(PipeExitHandler, NULL);
+ ThreadSpecificData *tsdPtr;
+ Tcl_MutexLock(&procMutex);
+ if (!initialized) {
+ initialized = 1;
+ procList = NULL;
+ Tcl_CreateExitHandler(ProcExitHandler, NULL);
+ }
+ Tcl_MutexUnlock(&procMutex);
+
+ tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
+ if (tsdPtr == NULL) {
+ tsdPtr = TCL_TSD_INIT(&dataKey);
+ tsdPtr->firstPipePtr = NULL;
+ Tcl_CreateEventSource(PipeSetupProc, PipeCheckProc, NULL);
+ Tcl_CreateThreadExitHandler(PipeExitHandler, NULL);
+ }
}
/*
@@ -237,8 +303,8 @@ PipeInit()
*/
static void
-PipeExitHandler(clientData)
- ClientData clientData; /* Old window proc */
+PipeExitHandler(
+ ClientData clientData) /* Old window proc */
{
Tcl_DeleteEventSource(PipeSetupProc, PipeCheckProc, NULL);
initialized = 0;
@@ -247,6 +313,32 @@ PipeExitHandler(clientData)
/*
*----------------------------------------------------------------------
*
+ * ProcExitHandler --
+ *
+ * This function is called to cleanup the process list before
+ * Tcl is unloaded.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Resets the process list.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+ProcExitHandler(
+ ClientData clientData) /* Old window proc */
+{
+ Tcl_MutexLock(&procMutex);
+ initialized = 0;
+ Tcl_MutexUnlock(&procMutex);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* PipeSetupProc --
*
* This procedure is invoked before Tcl_DoOneEvent blocks waiting
@@ -262,27 +354,45 @@ PipeExitHandler(clientData)
*/
void
-PipeSetupProc(data, flags)
- ClientData data; /* Not used. */
- int flags; /* Event flags as passed to Tcl_DoOneEvent. */
+PipeSetupProc(
+ ClientData data, /* Not used. */
+ int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
PipeInfo *infoPtr;
Tcl_Time blockTime = { 0, 0 };
+ int block = 1;
+ WinFile *filePtr;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!(flags & TCL_FILE_EVENTS)) {
return;
}
/*
- * Check to see if there is a watched pipe. If so, poll.
+ * Look to see if any events are already pending. If they are, poll.
*/
- for (infoPtr = firstPipePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
- if (infoPtr->watchMask) {
- Tcl_SetMaxBlockTime(&blockTime);
- break;
+ for (infoPtr = tsdPtr->firstPipePtr; infoPtr != NULL;
+ infoPtr = infoPtr->nextPtr) {
+ if (infoPtr->watchMask & TCL_WRITABLE) {
+ filePtr = (WinFile*) infoPtr->writeFile;
+ if ((filePtr->type == WIN32S_PIPE)
+ || (WaitForSingleObject(infoPtr->writable, 0)
+ != WAIT_TIMEOUT)) {
+ block = 0;
+ }
+ }
+ if (infoPtr->watchMask & TCL_READABLE) {
+ filePtr = (WinFile*) infoPtr->readFile;
+ if ((filePtr->type == WIN32S_PIPE)
+ || (WaitForRead(infoPtr, 0) >= 0)) {
+ block = 0;
+ }
}
}
+ if (!block) {
+ Tcl_SetMaxBlockTime(&blockTime);
+ }
}
/*
@@ -303,24 +413,54 @@ PipeSetupProc(data, flags)
*/
static void
-PipeCheckProc(data, flags)
- ClientData data; /* Not used. */
- int flags; /* Event flags as passed to Tcl_DoOneEvent. */
+PipeCheckProc(
+ ClientData data, /* Not used. */
+ int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
PipeInfo *infoPtr;
PipeEvent *evPtr;
+ WinFile *filePtr;
+ int needEvent;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!(flags & TCL_FILE_EVENTS)) {
return;
}
/*
- * Queue events for any watched pipes that don't already have events
+ * Queue events for any ready pipes that don't already have events
* queued.
*/
- for (infoPtr = firstPipePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
- if (infoPtr->watchMask && !(infoPtr->flags & PIPE_PENDING)) {
+ for (infoPtr = tsdPtr->firstPipePtr; infoPtr != NULL;
+ infoPtr = infoPtr->nextPtr) {
+ if (infoPtr->flags & PIPE_PENDING) {
+ continue;
+ }
+
+ /*
+ * Queue an event if the pipe is signaled for reading or writing.
+ */
+
+ needEvent = 0;
+ filePtr = (WinFile*) infoPtr->writeFile;
+ if (infoPtr->watchMask & TCL_WRITABLE) {
+ if ((filePtr->type == WIN32S_PIPE)
+ || (WaitForSingleObject(infoPtr->writable, 0)
+ != WAIT_TIMEOUT)) {
+ needEvent = 1;
+ }
+ }
+
+ filePtr = (WinFile*) infoPtr->readFile;
+ if (infoPtr->watchMask & TCL_READABLE) {
+ if ((filePtr->type == WIN32S_PIPE)
+ || (WaitForRead(infoPtr, 0) >= 0)) {
+ needEvent = 1;
+ }
+ }
+
+ if (needEvent) {
infoPtr->flags |= PIPE_PENDING;
evPtr = (PipeEvent *) ckalloc(sizeof(PipeEvent));
evPtr->header.proc = PipeEventProc;
@@ -348,8 +488,8 @@ PipeCheckProc(data, flags)
*/
static TclFile
-MakeFile(handle)
- HANDLE handle; /* Type-specific data. */
+MakeFile(
+ HANDLE handle) /* Type-specific data. */
{
WinFile *filePtr;
@@ -363,37 +503,6 @@ MakeFile(handle)
/*
*----------------------------------------------------------------------
*
- * 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
@@ -414,117 +523,58 @@ TclpMakeFile(channel, direction)
static int
TempFileName(name)
- char name[MAX_PATH]; /* Buffer in which name for temporary
+ WCHAR 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;
+ TCHAR *prefix;
+
+ prefix = (tclWinProcs->useWide) ? (TCHAR *) L"TCL" : (TCHAR *) "TCL";
+ if ((*tclWinProcs->getTempPathProc)(MAX_PATH, name) != 0) {
+ if ((*tclWinProcs->getTempFileNameProc)((TCHAR *) name, prefix, 0,
+ name) != 0) {
+ return 1;
}
}
- return 1;
+ if (tclWinProcs->useWide) {
+ ((WCHAR *) name)[0] = '.';
+ ((WCHAR *) name)[1] = '\0';
+ } else {
+ ((char *) name)[0] = '.';
+ ((char *) name)[1] = '\0';
+ }
+ return (*tclWinProcs->getTempFileNameProc)((TCHAR *) name, prefix, 0,
+ name);
}
/*
*----------------------------------------------------------------------
*
- * TclpCreateTempFile --
+ * TclpMakeFile --
*
- * 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.
+ * Make a TclFile from a channel.
*
* Results:
- * Returns a valid TclFile, or NULL on failure.
+ * Returns a new TclFile or NULL on failure.
*
* Side effects:
- * Creates a new temporary file.
+ * None.
*
*----------------------------------------------------------------------
*/
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. */
+TclpMakeFile(channel, direction)
+ Tcl_Channel channel; /* Channel to get file from. */
+ int direction; /* Either TCL_READABLE or TCL_WRITABLE. */
{
- 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 {
+ if (Tcl_GetChannelHandle(channel, direction,
+ (ClientData *) &handle) == TCL_OK) {
return MakeFile(handle);
+ } else {
+ return (TclFile) NULL;
}
-
- error:
- TclWinConvertError(GetLastError());
- CloseHandle(handle);
- DeleteFile(name);
- return NULL;
}
/*
@@ -546,12 +596,13 @@ TclpCreateTempFile(contents, namePtr)
TclFile
TclpOpenFile(path, mode)
- char *path;
- int mode;
+ CONST char *path; /* The name of the file to open. */
+ int mode; /* In what mode to open the file? */
{
HANDLE handle;
DWORD accessMode, createMode, shareMode, flags;
- SECURITY_ATTRIBUTES sec;
+ Tcl_DString ds;
+ TCHAR *nativePath;
/*
* Map the access bits to the NT access mode.
@@ -596,28 +647,21 @@ TclpOpenFile(path, mode)
break;
}
+ nativePath = Tcl_WinUtfToTChar(path, -1, &ds);
+
/*
* If the file is not being created, use the existing file attributes.
*/
flags = 0;
if (!(mode & O_CREAT)) {
- flags = GetFileAttributes(path);
+ flags = (*tclWinProcs->getFileAttributesProc)(nativePath);
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.
*/
@@ -627,10 +671,14 @@ TclpOpenFile(path, mode)
* Now we get to create the file.
*/
- handle = CreateFile(path, accessMode, shareMode, &sec, createMode, flags,
- (HANDLE) NULL);
+ handle = (*tclWinProcs->createFileProc)(nativePath, accessMode,
+ shareMode, NULL, createMode, flags, NULL);
+ Tcl_DStringFree(&ds);
+
if (handle == INVALID_HANDLE_VALUE) {
- DWORD err = GetLastError();
+ DWORD err;
+
+ err = GetLastError();
if ((err & 0xffffL) == ERROR_OPEN_FAILED) {
err = (mode & O_CREAT) ? ERROR_FILE_EXISTS : ERROR_FILE_NOT_FOUND;
}
@@ -652,6 +700,97 @@ TclpOpenFile(path, mode)
/*
*----------------------------------------------------------------------
*
+ * TclpCreateTempFile --
+ *
+ * This function opens a unique file with the property that it
+ * will be deleted when its file handle is closed. The temporary
+ * file is created in the system temporary directory.
+ *
+ * Results:
+ * Returns a valid TclFile, or NULL on failure.
+ *
+ * Side effects:
+ * Creates a new temporary file.
+ *
+ *----------------------------------------------------------------------
+ */
+
+TclFile
+TclpCreateTempFile(contents)
+ CONST char *contents; /* String to write into temp file, or NULL. */
+{
+ WCHAR name[MAX_PATH];
+ HANDLE handle;
+
+ if (TempFileName(name) == 0) {
+ return NULL;
+ }
+
+ handle = (*tclWinProcs->createFileProc)((TCHAR *) name,
+ GENERIC_READ | GENERIC_WRITE, 0, NULL, CREATE_ALWAYS,
+ FILE_ATTRIBUTE_TEMPORARY|FILE_FLAG_DELETE_ON_CLOSE, NULL);
+ if (handle == INVALID_HANDLE_VALUE) {
+ goto error;
+ }
+
+ /*
+ * Write the file out, doing line translations on the way.
+ */
+
+ if (contents != NULL) {
+ DWORD result, length;
+ CONST char *p;
+
+ 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;
+ }
+ }
+
+ /*
+ * 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;
+ lstrcpyA(tmpFilePtr->name, (char *) name);
+ return (TclFile) tmpFilePtr;
+ } else {
+ return MakeFile(handle);
+ }
+
+ error:
+ TclWinConvertError(GetLastError());
+ CloseHandle(handle);
+ (*tclWinProcs->deleteFileProc)((TCHAR *) name);
+ return NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclpCreatePipe --
*
* Creates an anonymous pipe. Under Win32s, creates a temp file
@@ -667,10 +806,10 @@ TclpOpenFile(path, mode)
*/
int
-TclpCreatePipe(readPipe, writePipe)
- TclFile *readPipe; /* Location to store file handle for
+TclpCreatePipe(
+ TclFile *readPipe, /* Location to store file handle for
* read side of pipe. */
- TclFile *writePipe; /* Location to store file handle for
+ TclFile *writePipe) /* Location to store file handle for
* write side of pipe. */
{
HANDLE readHandle, writeHandle;
@@ -684,22 +823,25 @@ TclpCreatePipe(readPipe, writePipe)
if (TclWinGetPlatformId() == VER_PLATFORM_WIN32s) {
WinPipe *readPipePtr, *writePipePtr;
char buf[MAX_PATH];
+ int bytes;
- if (TempFileName(buf) != 0) {
+ if (TempFileName((WCHAR *) buf) != 0) {
+ bytes = strlen((char *) buf) + 1;
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->fileName = (char *) ckalloc(bytes);
+ lstrcpyA(readPipePtr->fileName, 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;
+ *readPipe = (TclFile) readPipePtr;
+ *writePipe = (TclFile) writePipePtr;
return 1;
}
@@ -727,8 +869,8 @@ TclpCreatePipe(readPipe, writePipe)
*/
int
-TclpCloseFile(file)
- TclFile file; /* The file to close. */
+TclpCloseFile(
+ TclFile file) /* The file to close. */
{
WinFile *filePtr = (WinFile *) file;
WinPipe *pipePtr;
@@ -746,7 +888,7 @@ TclpCloseFile(file)
*/
if (filePtr->type == WIN32S_TMPFILE) {
- DeleteFile(((TmpFile*)filePtr)->name);
+ DeleteFileA(((TmpFile *) filePtr)->name);
}
break;
@@ -759,7 +901,7 @@ TclpCloseFile(file)
if (pipePtr->file.handle != INVALID_HANDLE_VALUE) {
CloseHandle(pipePtr->file.handle);
}
- DeleteFile(pipePtr->fileName);
+ DeleteFileA(pipePtr->fileName);
ckfree((char *) pipePtr->fileName);
}
break;
@@ -792,16 +934,19 @@ TclpCloseFile(file)
*/
unsigned long
-TclpGetPid(pid)
- Tcl_Pid pid; /* The HANDLE of the child process. */
+TclpGetPid(
+ Tcl_Pid pid) /* The HANDLE of the child process. */
{
ProcInfo *infoPtr;
-
+
+ Tcl_MutexLock(&procMutex);
for (infoPtr = procList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
if (infoPtr->hProcess == (HANDLE) pid) {
+ Tcl_MutexUnlock(&procMutex);
return infoPtr->dwProcessId;
}
}
+ Tcl_MutexUnlock(&procMutex);
return (unsigned long) -1;
}
@@ -823,7 +968,7 @@ TclpGetPid(pid)
*
* Results:
* The return value is TCL_ERROR and an error message is left in
- * interp->result if there was a problem creating the child
+ * the interp's result if there was a problem creating the child
* process. Otherwise, the return value is TCL_OK and *pidPtr is
* filled with the process id of the child process.
*
@@ -834,56 +979,50 @@ TclpGetPid(pid)
*/
int
-TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile,
- pidPtr)
- Tcl_Interp *interp; /* Interpreter in which to leave errors that
+TclpCreateProcess(
+ Tcl_Interp *interp, /* Interpreter in which to leave errors that
* occurred when creating the child process.
* Error messages from the child process
* itself are sent to errorFile. */
- int argc; /* Number of arguments in following array. */
- char **argv; /* Array of argument strings. argv[0]
+ 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
+ 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
+ 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
+ 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
+ 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;
+ Tcl_DString cmdLine; /* Complete command line (TCHAR). */
+ STARTUPINFOA startInfo;
PROCESS_INFORMATION procInfo;
SECURITY_ATTRIBUTES secAtts;
HANDLE hProcess, h, inputHandle, outputHandle, errorHandle;
- char execPath[MAX_PATH];
- char *originalName;
+ char execPath[MAX_PATH * TCL_UTF_MAX];
WinFile *filePtr;
- if (!initialized) {
- PipeInit();
- }
+ 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);
@@ -903,7 +1042,7 @@ TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile,
char *inputFileName, *outputFileName;
Tcl_DString inputTempFile, outputTempFile;
- BuildCommandLine(argc, argv, &cmdLine);
+ BuildCommandLine(execPath, argc, argv, &cmdLine);
ZeroMemory(&startInfo, sizeof(startInfo));
startInfo.cb = sizeof(startInfo);
@@ -922,8 +1061,9 @@ TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile,
h = INVALID_HANDLE_VALUE;
inputFileName = MakeTempFile(&inputTempFile);
if (inputFileName != NULL) {
- h = CreateFile(inputFileName, GENERIC_WRITE, 0,
- NULL, CREATE_ALWAYS, 0, NULL);
+ h = CreateFileA((char *) inputFileName,
+ GENERIC_WRITE, 0, NULL, CREATE_ALWAYS, 0,
+ NULL);
}
if (h == INVALID_HANDLE_VALUE) {
Tcl_AppendResult(interp, "couldn't duplicate input handle: ",
@@ -935,7 +1075,7 @@ TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile,
break;
}
case WIN32S_PIPE: {
- inputFileName = ((WinPipe*)inputFile)->fileName;
+ inputFileName = (char *) ((WinPipe *) inputFile)->fileName;
break;
}
}
@@ -944,7 +1084,7 @@ TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile,
inputFileName = "nul";
}
if (outputFile != NULL) {
- filePtr = (WinFile *)outputFile;
+ filePtr = (WinFile *) outputFile;
if (filePtr->type == WIN_FILE) {
outputFileName = MakeTempFile(&outputTempFile);
if (outputFileName == NULL) {
@@ -954,7 +1094,7 @@ TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile,
}
outputHandle = filePtr->handle;
} else if (filePtr->type == WIN32S_PIPE) {
- outputFileName = ((WinPipe*)outputFile)->fileName;
+ outputFileName = (char *) ((WinPipe *) outputFile)->fileName;
}
}
if (outputFileName == NULL) {
@@ -980,9 +1120,9 @@ TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile,
result = TCL_OK;
}
} else {
- if (CreateProcess(NULL, Tcl_DStringValue(&cmdLine), NULL, NULL,
- FALSE, DETACHED_PROCESS, NULL, NULL, &startInfo,
- &procInfo) != 0) {
+ if (CreateProcessA(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) {
@@ -1001,15 +1141,17 @@ TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile,
ProcInfo *procPtr = (ProcInfo *) ckalloc(sizeof(ProcInfo));
procPtr->hProcess = procInfo.hProcess;
procPtr->dwProcessId = procInfo.dwProcessId;
+ Tcl_MutexLock(&procMutex);
procPtr->nextPtr = procList;
procList = procPtr;
+ Tcl_MutexUnlock(&procMutex);
}
result = TCL_OK;
}
}
if (result != TCL_OK) {
TclWinConvertError(GetLastError());
- Tcl_AppendResult(interp, "couldn't execute \"", originalName,
+ Tcl_AppendResult(interp, "couldn't execute \"", argv[0],
"\": ", Tcl_PosixError(interp), (char *) NULL);
}
@@ -1021,7 +1163,7 @@ TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile,
* file owned by the caller.
*/
- h = CreateFile(outputFileName, GENERIC_READ, 0, NULL, OPEN_ALWAYS,
+ h = CreateFileA(outputFileName, GENERIC_READ, 0, NULL, OPEN_ALWAYS,
0, NULL);
if (h != INVALID_HANDLE_VALUE) {
CopyChannel(outputHandle, h);
@@ -1030,11 +1172,11 @@ TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile,
}
if (inputFileName == Tcl_DStringValue(&inputTempFile)) {
- DeleteFile(inputFileName);
+ DeleteFileA(inputFileName);
}
if (outputFileName == Tcl_DStringValue(&outputTempFile)) {
- DeleteFile(outputFileName);
+ DeleteFileA(outputFileName);
}
Tcl_DStringFree(&inputTempFile);
@@ -1144,7 +1286,7 @@ TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile,
CloseHandle(h);
}
} else {
- startInfo.hStdOutput = CreateFile("NUL:", GENERIC_WRITE, 0,
+ startInfo.hStdOutput = CreateFileA("NUL:", GENERIC_WRITE, 0,
&secAtts, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL);
}
} else {
@@ -1164,7 +1306,7 @@ TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile,
* deep sink.
*/
- startInfo.hStdError = CreateFile("NUL:", GENERIC_WRITE, 0,
+ startInfo.hStdError = CreateFileA("NUL:", GENERIC_WRITE, 0,
&secAtts, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
} else {
DuplicateHandle(hProcess, errorHandle, hProcess, &startInfo.hStdError,
@@ -1275,16 +1417,22 @@ TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile,
* using ab~1.def instead of "a b.default").
*/
- BuildCommandLine(argc, argv, &cmdLine);
+ BuildCommandLine(execPath, argc, argv, &cmdLine);
- if (!CreateProcess(NULL, Tcl_DStringValue(&cmdLine), NULL, NULL, TRUE,
- createFlags, NULL, NULL, &startInfo, &procInfo)) {
+ if ((*tclWinProcs->createProcessProc)(NULL,
+ (TCHAR *) Tcl_DStringValue(&cmdLine), NULL, NULL, TRUE,
+ createFlags, NULL, NULL, &startInfo, &procInfo) == 0) {
TclWinConvertError(GetLastError());
- Tcl_AppendResult(interp, "couldn't execute \"", originalName,
+ Tcl_AppendResult(interp, "couldn't execute \"", argv[0],
"\": ", Tcl_PosixError(interp), (char *) NULL);
goto end;
}
+ /*
+ * This wait is used to force the OS to give some time to the DOS
+ * process.
+ */
+
if (applType == APPL_DOS) {
WaitForSingleObject(hProcess, 50);
}
@@ -1306,8 +1454,10 @@ TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile,
ProcInfo *procPtr = (ProcInfo *) ckalloc(sizeof(ProcInfo));
procPtr->hProcess = procInfo.hProcess;
procPtr->dwProcessId = procInfo.dwProcessId;
+ Tcl_MutexLock(&procMutex);
procPtr->nextPtr = procList;
procList = procPtr;
+ Tcl_MutexUnlock(&procMutex);
}
result = TCL_OK;
@@ -1346,7 +1496,9 @@ TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile,
static BOOL
HasConsole()
{
- HANDLE handle = CreateFile("CONOUT$", GENERIC_WRITE, FILE_SHARE_WRITE,
+ HANDLE handle;
+
+ handle = CreateFileA("CONOUT$", GENERIC_WRITE, FILE_SHARE_WRITE,
NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
if (handle != INVALID_HANDLE_VALUE) {
@@ -1394,18 +1546,22 @@ HasConsole()
*/
static int
-ApplicationType(interp, originalName, fullPath)
+ApplicationType(interp, originalName, fullName)
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
+ char fullName[]; /* Filled with complete path to
* application. */
{
- int applType, i;
+ int applType, i, nameLen, found;
HANDLE hFile;
- char *ext, *rest;
+ TCHAR *rest;
+ char *ext;
char buf[2];
- DWORD read;
+ DWORD attr, read;
IMAGE_DOS_HEADER header;
+ Tcl_DString nameBuf, ds;
+ TCHAR *nativeName;
+ WCHAR nativeFullPath[MAX_PATH];
static char extensions[][5] = {"", ".com", ".exe", ".bat"};
/* Look for the program as an external program. First try the name
@@ -1422,29 +1578,43 @@ ApplicationType(interp, originalName, fullPath)
*/
applType = APPL_NONE;
+ Tcl_DStringInit(&nameBuf);
+ Tcl_DStringAppend(&nameBuf, originalName, -1);
+ nameLen = Tcl_DStringLength(&nameBuf);
+
for (i = 0; i < (int) (sizeof(extensions) / sizeof(extensions[0])); i++) {
- lstrcpyn(fullPath, originalName, MAX_PATH - 5);
- lstrcat(fullPath, extensions[i]);
-
- SearchPath(NULL, fullPath, NULL, MAX_PATH, fullPath, &rest);
+ Tcl_DStringSetLength(&nameBuf, nameLen);
+ Tcl_DStringAppend(&nameBuf, extensions[i], -1);
+ nativeName = Tcl_WinUtfToTChar(Tcl_DStringValue(&nameBuf),
+ Tcl_DStringLength(&nameBuf), &ds);
+ found = (*tclWinProcs->searchPathProc)(NULL, nativeName, NULL,
+ MAX_PATH, nativeFullPath, &rest);
+ Tcl_DStringFree(&ds);
+ if (found == 0) {
+ continue;
+ }
/*
* Ignore matches on directories or data files, return if identified
* a known type.
*/
- if (GetFileAttributes(fullPath) & FILE_ATTRIBUTE_DIRECTORY) {
+ attr = (*tclWinProcs->getFileAttributesProc)((TCHAR *) nativeFullPath);
+ if ((attr == 0xffffffff) || (attr & FILE_ATTRIBUTE_DIRECTORY)) {
continue;
}
+ strcpy(fullName, Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds));
+ Tcl_DStringFree(&ds);
- ext = strrchr(fullPath, '.');
- if ((ext != NULL) && (strcmpi(ext, ".bat") == 0)) {
+ ext = strrchr(fullName, '.');
+ if ((ext != NULL) && (stricmp(ext, ".bat") == 0)) {
applType = APPL_DOS;
break;
}
- hFile = CreateFile(fullPath, GENERIC_READ, FILE_SHARE_READ, NULL,
- OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
+ hFile = (*tclWinProcs->createFileProc)((TCHAR *) nativeFullPath,
+ GENERIC_READ, FILE_SHARE_READ, NULL, OPEN_EXISTING,
+ FILE_ATTRIBUTE_NORMAL, NULL);
if (hFile == INVALID_HANDLE_VALUE) {
continue;
}
@@ -1461,7 +1631,7 @@ ApplicationType(interp, originalName, fullPath)
*/
CloseHandle(hFile);
- if ((ext != NULL) && (strcmpi(ext, ".com") == 0)) {
+ if ((ext != NULL) && (strcmp(ext, ".com") == 0)) {
applType = APPL_DOS;
break;
}
@@ -1505,6 +1675,7 @@ ApplicationType(interp, originalName, fullPath)
}
break;
}
+ Tcl_DStringFree(&nameBuf);
if (applType == APPL_NONE) {
TclWinConvertError(GetLastError());
@@ -1521,7 +1692,10 @@ ApplicationType(interp, originalName, fullPath)
* application name from the arguments.
*/
- GetShortPathName(fullPath, fullPath, MAX_PATH);
+ (*tclWinProcs->getShortPathNameProc)((TCHAR *) nativeFullPath,
+ nativeFullPath, MAX_PATH);
+ strcpy(fullName, Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds));
+ Tcl_DStringFree(&ds);
}
return applType;
}
@@ -1546,34 +1720,42 @@ ApplicationType(interp, originalName, fullPath)
*/
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. */
+BuildCommandLine(
+ CONST char *executable, /* Full path of executable (including
+ * extension). Replacement for argv[0]. */
+ int argc, /* Number of arguments. */
+ char **argv, /* Argument strings in UTF. */
+ Tcl_DString *linePtr) /* Initialized Tcl_DString that receives the
+ * command line (TCHAR). */
{
- char *start, *special;
+ CONST char *arg, *start, *special;
int quote, i;
+ Tcl_DString ds;
+
+ Tcl_DStringInit(&ds);
for (i = 0; i < argc; i++) {
- if (i > 0) {
- Tcl_DStringAppend(linePtr, " ", 1);
+ if (i == 0) {
+ arg = executable;
+ } else {
+ arg = argv[i];
+ Tcl_DStringAppend(&ds, " ", 1);
}
quote = 0;
- for (start = argv[i]; *start != '\0'; start++) {
- if (isspace(*start)) {
+ for (start = arg; *start != '\0'; start++) {
+ if (isspace(*start)) { /* INTL: ISO space. */
quote = 1;
- Tcl_DStringAppend(linePtr, "\"", 1);
+ Tcl_DStringAppend(&ds, "\"", 1);
break;
}
}
- start = argv[i];
- for (special = argv[i]; ; ) {
+ start = arg;
+ for (special = arg; ; ) {
if ((*special == '\\') &&
(special[1] == '\\' || special[1] == '"')) {
- Tcl_DStringAppend(linePtr, start, special - start);
+ Tcl_DStringAppend(&ds, start, special - start);
start = special;
while (1) {
special++;
@@ -1583,19 +1765,19 @@ BuildCommandLine(argc, argv, linePtr)
* N * 2 + 1 backslashes then a quote.
*/
- Tcl_DStringAppend(linePtr, start, special - start);
+ Tcl_DStringAppend(&ds, start, special - start);
break;
}
if (*special != '\\') {
break;
}
}
- Tcl_DStringAppend(linePtr, start, special - start);
+ Tcl_DStringAppend(&ds, start, special - start);
start = special;
}
if (*special == '"') {
- Tcl_DStringAppend(linePtr, start, special - start);
- Tcl_DStringAppend(linePtr, "\\\"", 2);
+ Tcl_DStringAppend(&ds, start, special - start);
+ Tcl_DStringAppend(&ds, "\\\"", 2);
start = special + 1;
}
if (*special == '\0') {
@@ -1603,11 +1785,13 @@ BuildCommandLine(argc, argv, linePtr)
}
special++;
}
- Tcl_DStringAppend(linePtr, start, special - start);
+ Tcl_DStringAppend(&ds, start, special - start);
if (quote) {
- Tcl_DStringAppend(linePtr, "\"", 1);
+ Tcl_DStringAppend(&ds, "\"", 1);
}
}
+ Tcl_WinUtfToTChar(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds), linePtr);
+ Tcl_DStringFree(&ds);
}
/*
@@ -1638,7 +1822,7 @@ MakeTempFile(namePtr)
{
char name[MAX_PATH];
- if (TempFileName(name) == 0) {
+ if (TempFileName((WCHAR *) name) == 0) {
return NULL;
}
@@ -1667,9 +1851,9 @@ MakeTempFile(namePtr)
*/
static void
-CopyChannel(dst, src)
- HANDLE dst; /* Destination file. */
- HANDLE src; /* Source file. */
+CopyChannel(
+ HANDLE dst, /* Destination file. */
+ HANDLE src) /* Source file. */
{
char buf[8192];
DWORD dwRead, dwWrite;
@@ -1703,29 +1887,42 @@ CopyChannel(dst, src)
*/
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
+TclpCreateCommandChannel(
+ TclFile readFile, /* If non-null, gives the file for reading. */
+ TclFile writeFile, /* If non-null, gives the file for writing. */
+ TclFile errorFile, /* If non-null, gives the file where errors
* can be read. */
- int numPids; /* The number of pids in the pid array. */
- Tcl_Pid *pidPtr; /* An array of process identifiers. */
+ int numPids, /* The number of pids in the pid array. */
+ Tcl_Pid *pidPtr) /* An array of process identifiers. */
{
- char channelName[20];
+ char channelName[16 + TCL_INTEGER_SPACE];
int channelId;
+ DWORD id;
PipeInfo *infoPtr = (PipeInfo *) ckalloc((unsigned) sizeof(PipeInfo));
+ OSVERSIONINFO os;
+ int useThreads;
- if (!initialized) {
- PipeInit();
- }
+ /*
+ * Fetch the OS version info.
+ */
+
+ os.dwOSVersionInfoSize = sizeof(os);
+ GetVersionEx(&os);
+ useThreads = (os.dwPlatformId != VER_PLATFORM_WIN32s);
+
+ PipeInit();
infoPtr->watchMask = 0;
infoPtr->flags = 0;
+ infoPtr->readFlags = 0;
infoPtr->readFile = readFile;
infoPtr->writeFile = writeFile;
infoPtr->errorFile = errorFile;
infoPtr->numPids = numPids;
infoPtr->pidPtr = pidPtr;
+ infoPtr->writeBuf = 0;
+ infoPtr->writeBufLen = 0;
+ infoPtr->writeError = 0;
/*
* Use one of the fds associated with the channel as the
@@ -1736,7 +1933,7 @@ TclpCreateCommandChannel(readFile, writeFile, errorFile, numPids, pidPtr)
WinPipe *pipePtr = (WinPipe *) readFile;
if (pipePtr->file.type == WIN32S_PIPE
&& pipePtr->file.handle == INVALID_HANDLE_VALUE) {
- pipePtr->file.handle = CreateFile(pipePtr->fileName, GENERIC_READ,
+ pipePtr->file.handle = CreateFileA(pipePtr->fileName, GENERIC_READ,
0, NULL, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL);
}
channelId = (int) pipePtr->file.handle;
@@ -1749,10 +1946,39 @@ TclpCreateCommandChannel(readFile, writeFile, errorFile, numPids, pidPtr)
}
infoPtr->validMask = 0;
+
+ infoPtr->threadId = Tcl_GetCurrentThread();
+
if (readFile != NULL) {
+ if (useThreads) {
+ /*
+ * Start the background reader thread.
+ */
+
+ infoPtr->readable = CreateEvent(NULL, TRUE, TRUE, NULL);
+ infoPtr->startReader = CreateEvent(NULL, FALSE, FALSE, NULL);
+ infoPtr->readThread = CreateThread(NULL, 8000, PipeReaderThread,
+ infoPtr, 0, &id);
+ } else {
+ infoPtr->readThread = 0;
+ }
infoPtr->validMask |= TCL_READABLE;
+ } else {
+ infoPtr->readThread = 0;
}
if (writeFile != NULL) {
+ if (useThreads) {
+ /*
+ * Start the background writeer thwrite.
+ */
+
+ infoPtr->writable = CreateEvent(NULL, TRUE, TRUE, NULL);
+ infoPtr->startWriter = CreateEvent(NULL, FALSE, FALSE, NULL);
+ infoPtr->writeThread = CreateThread(NULL, 8000, PipeWriterThread,
+ infoPtr, 0, &id);
+ } else {
+ infoPtr->writeThread = 0;
+ }
infoPtr->validMask |= TCL_WRITABLE;
}
@@ -1762,7 +1988,7 @@ TclpCreateCommandChannel(readFile, writeFile, errorFile, numPids, pidPtr)
* be more natural to use "pipe%d".
*/
- sprintf(channelName, "file%d", channelId);
+ wsprintfA(channelName, "file%d", channelId);
infoPtr->channel = Tcl_CreateChannel(&pipeChannelType, channelName,
(ClientData) infoPtr, infoPtr->validMask);
@@ -1785,26 +2011,26 @@ TclpCreateCommandChannel(readFile, writeFile, errorFile, numPids, pidPtr)
* TclGetAndDetachPids --
*
* Stores a list of the command PIDs for a command channel in
- * interp->result.
+ * the interp's result.
*
* Results:
* None.
*
* Side effects:
- * Modifies interp->result.
+ * Modifies the interp's result.
*
*----------------------------------------------------------------------
*/
void
-TclGetAndDetachPids(interp, chan)
- Tcl_Interp *interp;
- Tcl_Channel chan;
+TclGetAndDetachPids(
+ Tcl_Interp *interp,
+ Tcl_Channel chan)
{
PipeInfo *pipePtr;
Tcl_ChannelType *chanTypePtr;
int i;
- char buf[20];
+ char buf[TCL_INTEGER_SPACE];
/*
* Punt if the channel is not a command channel.
@@ -1817,7 +2043,7 @@ TclGetAndDetachPids(interp, chan)
pipePtr = (PipeInfo *) Tcl_GetChannelInstanceData(chan);
for (i = 0; i < pipePtr->numPids; i++) {
- sprintf(buf, "%lu", TclpGetPid(pipePtr->pidPtr[i]));
+ wsprintfA(buf, "%lu", TclpGetPid(pipePtr->pidPtr[i]));
Tcl_AppendElement(interp, buf);
Tcl_DetachPids(1, &(pipePtr->pidPtr[i]));
}
@@ -1844,9 +2070,9 @@ TclGetAndDetachPids(interp, chan)
*/
static int
-PipeBlockModeProc(instanceData, mode)
- ClientData instanceData; /* Instance data for channel. */
- int mode; /* TCL_MODE_BLOCKING or
+PipeBlockModeProc(
+ ClientData instanceData, /* Instance data for channel. */
+ int mode) /* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
PipeInfo *infoPtr = (PipeInfo *) instanceData;
@@ -1869,7 +2095,7 @@ PipeBlockModeProc(instanceData, mode)
/*
*----------------------------------------------------------------------
*
- * PipeCloseProc --
+ * PipeClose2Proc --
*
* Closes a pipe based IO channel.
*
@@ -1883,41 +2109,86 @@ PipeBlockModeProc(instanceData, mode)
*/
static int
-PipeCloseProc(instanceData, interp)
- ClientData instanceData; /* Pointer to PipeInfo structure. */
- Tcl_Interp *interp; /* For error reporting. */
+PipeClose2Proc(
+ ClientData instanceData, /* Pointer to PipeInfo structure. */
+ Tcl_Interp *interp, /* For error reporting. */
+ int flags) /* Flags that indicate which side to close. */
{
PipeInfo *pipePtr = (PipeInfo *) instanceData;
Tcl_Channel errChan;
int errorCode, result;
PipeInfo *infoPtr, **nextPtrPtr;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- /*
- * Remove the file from the list of watched files.
- */
+ errorCode = 0;
+ if ((!flags || (flags == TCL_CLOSE_READ))
+ && (pipePtr->readFile != NULL)) {
+ /*
+ * Clean up the background thread if necessary. Note that this
+ * must be done before we can close the file, since the
+ * thread may be blocking trying to read from the pipe.
+ */
- for (nextPtrPtr = &firstPipePtr, infoPtr = *nextPtrPtr; infoPtr != NULL;
- nextPtrPtr = &infoPtr->nextPtr, infoPtr = *nextPtrPtr) {
- if (infoPtr == (PipeInfo *)pipePtr) {
- *nextPtrPtr = infoPtr->nextPtr;
- break;
+ if (pipePtr->readThread) {
+ TerminateThread(pipePtr->readThread, 0);
+ CloseHandle(pipePtr->readThread);
+ CloseHandle(pipePtr->readable);
+ CloseHandle(pipePtr->startReader);
+ pipePtr->readThread = NULL;
}
- }
-
- errorCode = 0;
- if (pipePtr->readFile != NULL) {
if (TclpCloseFile(pipePtr->readFile) != 0) {
errorCode = errno;
}
+ pipePtr->validMask &= ~TCL_READABLE;
+ pipePtr->readFile = NULL;
}
- if (pipePtr->writeFile != NULL) {
+ if ((!flags || (flags & TCL_CLOSE_WRITE))
+ && (pipePtr->writeFile != NULL)) {
+ /*
+ * Wait for the writer thread to finish the current buffer, then
+ * terminate the thread and close the handles. If the channel is
+ * nonblocking, there should be no pending write operations.
+ */
+
+ if (pipePtr->writeThread) {
+ WaitForSingleObject(pipePtr->writable, INFINITE);
+ TerminateThread(pipePtr->writeThread, 0);
+ CloseHandle(pipePtr->writeThread);
+ CloseHandle(pipePtr->writable);
+ CloseHandle(pipePtr->startWriter);
+ pipePtr->writeThread = NULL;
+ }
if (TclpCloseFile(pipePtr->writeFile) != 0) {
if (errorCode == 0) {
errorCode = errno;
}
}
+ pipePtr->validMask &= ~TCL_WRITABLE;
+ pipePtr->writeFile = NULL;
}
-
+ pipePtr->watchMask &= pipePtr->validMask;
+
+ /*
+ * Don't free the channel if any of the flags were set.
+ */
+
+ if (flags) {
+ return errorCode;
+ }
+
+ /*
+ * Remove the file from the list of watched files.
+ */
+
+ for (nextPtrPtr = &(tsdPtr->firstPipePtr), infoPtr = *nextPtrPtr;
+ infoPtr != NULL;
+ nextPtrPtr = &infoPtr->nextPtr, infoPtr = *nextPtrPtr) {
+ if (infoPtr == (PipeInfo *)pipePtr) {
+ *nextPtrPtr = infoPtr->nextPtr;
+ break;
+ }
+ }
+
/*
* Wrap the error file into a channel and give it to the cleanup
* routine. If we are running in Win32s, just delete the error file
@@ -1937,6 +2208,7 @@ PipeCloseProc(instanceData, interp)
filePtr = (WinFile*)pipePtr->errorFile;
errChan = Tcl_MakeFileChannel((ClientData) filePtr->handle,
TCL_READABLE);
+ ckfree((char *) filePtr);
}
} else {
errChan = NULL;
@@ -1946,6 +2218,7 @@ PipeCloseProc(instanceData, interp)
if (pipePtr->numPids > 0) {
ckfree((char *) pipePtr->pidPtr);
}
+
ckfree((char*) pipePtr);
if (errorCode == 0) {
@@ -1973,17 +2246,17 @@ PipeCloseProc(instanceData, interp)
*/
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
+PipeInputProc(
+ ClientData instanceData, /* Pipe state. */
+ char *buf, /* Where to store data read. */
+ int bufSize, /* How much space is available
* in the buffer? */
- int *errorCode; /* Where to store error code. */
+ int *errorCode) /* Where to store error code. */
{
PipeInfo *infoPtr = (PipeInfo *) instanceData;
WinFile *filePtr = (WinFile*) infoPtr->readFile;
- DWORD count;
- DWORD bytesRead;
+ DWORD count, bytesRead = 0;
+ int result;
*errorCode = 0;
if (filePtr->type == WIN32S_PIPE) {
@@ -1991,7 +2264,7 @@ PipeInputProc(instanceData, buf, bufSize, errorCode)
panic("PipeInputProc: child process isn't finished writing");
}
if (filePtr->handle == INVALID_HANDLE_VALUE) {
- filePtr->handle = CreateFile(((WinPipe *)filePtr)->fileName,
+ filePtr->handle = CreateFileA(((WinPipe *)filePtr)->fileName,
GENERIC_READ, 0, NULL, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL,
NULL);
}
@@ -2000,50 +2273,63 @@ PipeInputProc(instanceData, buf, bufSize, errorCode)
}
} 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.
+ * Synchronize with the reader thread.
*/
- if (PeekNamedPipe(filePtr->handle, (LPVOID) NULL, (DWORD) 0,
- (LPDWORD) NULL, &count, (LPDWORD) NULL) == TRUE) {
- if ((count != 0) && ((DWORD) bufSize > count)) {
- bufSize = (int) count;
+ result = WaitForRead(infoPtr, (infoPtr->flags & PIPE_ASYNC) ? 0 : 1);
- /*
- * 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.
- */
+ /*
+ * If an error occurred, return immediately.
+ */
+
+ if (result == -1) {
+ *errorCode = errno;
+ return -1;
+ }
+
+ if (infoPtr->readFlags & PIPE_EXTRABYTE) {
+ /*
+ * The reader thread consumed 1 byte as a side effect of
+ * waiting so we need to move it into the buffer.
+ */
-/* } else if ((count == 0) && (infoPtr->flags & PIPE_ASYNC)) { */
-/* errno = *errorCode = EAGAIN; */
-/* return -1; */
- } else if ((count == 0) && !(infoPtr->flags & PIPE_ASYNC)) {
- bufSize = 1;
+ *buf = infoPtr->extraByte;
+ infoPtr->readFlags &= ~PIPE_EXTRABYTE;
+ buf++;
+ bufSize--;
+ bytesRead = 1;
+
+ /*
+ * If further read attempts would block, return what we have.
+ */
+
+ if (result == 0) {
+ return bytesRead;
}
- } 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.
+ * Attempt to read bufSize bytes. The read will return immediately
+ * if there is any data available. Otherwise it will block until
+ * at least one byte is available or an EOF occurs.
*/
- if (ReadFile(filePtr->handle, (LPVOID) buf, (DWORD) bufSize, &bytesRead,
- (LPOVERLAPPED) NULL) == FALSE) {
- goto error;
+ if (ReadFile(filePtr->handle, (LPVOID) buf, (DWORD) bufSize, &count,
+ (LPOVERLAPPED) NULL) == TRUE) {
+ return bytesRead + count;
+ } else if (bytesRead) {
+ /*
+ * Ignore errors if we have data to return.
+ */
+
+ return bytesRead;
}
-
- return bytesRead;
error:
TclWinConvertError(GetLastError());
if (errno == EPIPE) {
+ infoPtr->readFlags |= PIPE_EOF;
return 0;
}
*errorCode = errno;
@@ -2069,27 +2355,78 @@ PipeInputProc(instanceData, buf, bufSize, errorCode)
*/
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. */
+PipeOutputProc(
+ ClientData instanceData, /* Pipe state. */
+ char *buf, /* The data buffer. */
+ int toWrite, /* How many bytes to write? */
+ int *errorCode) /* Where to store error code. */
{
PipeInfo *infoPtr = (PipeInfo *) instanceData;
WinFile *filePtr = (WinFile*) infoPtr->writeFile;
- DWORD bytesWritten;
+ DWORD bytesWritten, timeout;
*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;
+ timeout = (infoPtr->flags & PIPE_ASYNC) ? 0 : INFINITE;
+ if (WaitForSingleObject(infoPtr->writable, timeout) == WAIT_TIMEOUT) {
+ /*
+ * The writer thread is blocked waiting for a write to complete
+ * and the channel is in non-blocking mode.
+ */
+
+ errno = EAGAIN;
+ goto error;
+ }
+
+ /*
+ * Check for a background error on the last write.
+ */
+
+ if (infoPtr->writeError) {
+ TclWinConvertError(infoPtr->writeError);
+ infoPtr->writeError = 0;
+ goto error;
+ }
+
+ if (infoPtr->flags & PIPE_ASYNC) {
+ /*
+ * The pipe is non-blocking, so copy the data into the output
+ * buffer and restart the writer thread.
+ */
+
+ if (toWrite > infoPtr->writeBufLen) {
+ /*
+ * Reallocate the buffer to be large enough to hold the data.
+ */
+
+ if (infoPtr->writeBuf) {
+ ckfree(infoPtr->writeBuf);
+ }
+ infoPtr->writeBufLen = toWrite;
+ infoPtr->writeBuf = ckalloc(toWrite);
+ }
+ memcpy(infoPtr->writeBuf, buf, toWrite);
+ infoPtr->toWrite = toWrite;
+ ResetEvent(infoPtr->writable);
+ SetEvent(infoPtr->startWriter);
+ bytesWritten = toWrite;
+ } else {
+ /*
+ * In the blocking case, just try to write the buffer directly.
+ * This avoids an unnecessary copy.
+ */
+
+ if (WriteFile(filePtr->handle, (LPVOID) buf, (DWORD) toWrite,
+ &bytesWritten, (LPOVERLAPPED) NULL) == FALSE) {
+ TclWinConvertError(GetLastError());
+ goto error;
+ }
}
return bytesWritten;
+
+ error:
+ *errorCode = errno;
+ return -1;
+
}
/*
@@ -2114,16 +2451,16 @@ PipeOutputProc(instanceData, buf, toWrite, errorCode)
*/
static int
-PipeEventProc(evPtr, flags)
- Tcl_Event *evPtr; /* Event to service. */
- int flags; /* Flags that indicate what events to
+PipeEventProc(
+ Tcl_Event *evPtr, /* Event to service. */
+ int flags) /* Flags that indicate what events to
* handle, such as TCL_FILE_EVENTS. */
{
PipeEvent *pipeEvPtr = (PipeEvent *)evPtr;
PipeInfo *infoPtr;
WinFile *filePtr;
int mask;
-/* DWORD count;*/
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!(flags & TCL_FILE_EVENTS)) {
return 0;
@@ -2136,7 +2473,8 @@ PipeEventProc(evPtr, flags)
* event is in the queue.
*/
- for (infoPtr = firstPipePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
+ for (infoPtr = tsdPtr->firstPipePtr; infoPtr != NULL;
+ infoPtr = infoPtr->nextPtr) {
if (pipeEvPtr->infoPtr == infoPtr) {
infoPtr->flags &= ~(PIPE_PENDING);
break;
@@ -2154,36 +2492,29 @@ PipeEventProc(evPtr, flags)
/*
* 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.
+ * as being writable unless we have detected EOF.
*/
- 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.
- */
+ filePtr = (WinFile*) ((PipeInfo*)infoPtr)->writeFile;
+ mask = 0;
+ if (infoPtr->watchMask & TCL_WRITABLE) {
+ if ((filePtr->type == WIN32S_PIPE)
+ || (WaitForSingleObject(infoPtr->writable, 0)
+ != WAIT_TIMEOUT)) {
+ mask = TCL_WRITABLE;
+ }
+ }
-/* if (GetLastError() == ERROR_BROKEN_PIPE) { */
-/* mask = TCL_READABLE; */
-/* } */
-/* } */
- } else {
- mask = TCL_READABLE | TCL_WRITABLE;
+ filePtr = (WinFile*) ((PipeInfo*)infoPtr)->readFile;
+ if (infoPtr->watchMask & TCL_READABLE) {
+ if ((filePtr->type == WIN32S_PIPE)
+ || (WaitForRead(infoPtr, 0) >= 0)) {
+ if (infoPtr->readFlags & PIPE_EOF) {
+ mask = TCL_READABLE;
+ } else {
+ mask |= TCL_READABLE;
+ }
+ }
}
/*
@@ -2212,27 +2543,29 @@ PipeEventProc(evPtr, flags)
*/
static void
-PipeWatchProc(instanceData, mask)
- ClientData instanceData; /* Pipe state. */
- int mask; /* What events to watch for; OR-ed
+PipeWatchProc(
+ ClientData instanceData, /* Pipe state. */
+ int mask) /* What events to watch for, OR-ed
* combination of TCL_READABLE,
* TCL_WRITABLE and TCL_EXCEPTION. */
{
PipeInfo **nextPtrPtr, *ptr;
PipeInfo *infoPtr = (PipeInfo *) instanceData;
int oldMask = infoPtr->watchMask;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
- * For now, we just send a message to ourselves so we can poll the
- * channel for readable events.
+ * Since most of the work is handled by the background threads,
+ * we just need to update the watchMask and then force the notifier
+ * to poll once.
*/
infoPtr->watchMask = mask & infoPtr->validMask;
if (infoPtr->watchMask) {
Tcl_Time blockTime = { 0, 0 };
if (!oldMask) {
- infoPtr->nextPtr = firstPipePtr;
- firstPipePtr = infoPtr;
+ infoPtr->nextPtr = tsdPtr->firstPipePtr;
+ tsdPtr->firstPipePtr = infoPtr;
}
Tcl_SetMaxBlockTime(&blockTime);
} else {
@@ -2241,7 +2574,7 @@ PipeWatchProc(instanceData, mask)
* Remove the pipe from the list of watched pipes.
*/
- for (nextPtrPtr = &firstPipePtr, ptr = *nextPtrPtr;
+ for (nextPtrPtr = &(tsdPtr->firstPipePtr), ptr = *nextPtrPtr;
ptr != NULL;
nextPtrPtr = &ptr->nextPtr, ptr = *nextPtrPtr) {
if (infoPtr == ptr) {
@@ -2272,10 +2605,10 @@ PipeWatchProc(instanceData, mask)
*/
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. */
+PipeGetHandleProc(
+ ClientData instanceData, /* The pipe state. */
+ int direction, /* TCL_READABLE or TCL_WRITABLE */
+ ClientData *handlePtr) /* Where to store the handle. */
{
PipeInfo *infoPtr = (PipeInfo *) instanceData;
WinFile *filePtr;
@@ -2284,7 +2617,7 @@ PipeGetHandleProc(instanceData, direction, handlePtr)
filePtr = (WinFile*) infoPtr->readFile;
if (filePtr->type == WIN32S_PIPE) {
if (filePtr->handle == INVALID_HANDLE_VALUE) {
- filePtr->handle = CreateFile(((WinPipe *)filePtr)->fileName,
+ filePtr->handle = CreateFileA(((WinPipe *)filePtr)->fileName,
GENERIC_READ, 0, NULL, OPEN_ALWAYS,
FILE_ATTRIBUTE_NORMAL, NULL);
}
@@ -2323,19 +2656,17 @@ PipeGetHandleProc(instanceData, direction, handlePtr)
*/
Tcl_Pid
-Tcl_WaitPid(pid, statPtr, options)
- Tcl_Pid pid;
- int *statPtr;
- int options;
+Tcl_WaitPid(
+ Tcl_Pid pid,
+ int *statPtr,
+ int options)
{
ProcInfo *infoPtr, **prevPtrPtr;
int flags;
Tcl_Pid result;
DWORD ret;
- if (!initialized) {
- PipeInit();
- }
+ PipeInit();
/*
* If no pid is specified, do nothing.
@@ -2350,6 +2681,7 @@ Tcl_WaitPid(pid, statPtr, options)
* Find the process on the process list.
*/
+ Tcl_MutexLock(&procMutex);
prevPtrPtr = &procList;
for (infoPtr = procList; infoPtr != NULL;
prevPtrPtr = &infoPtr->nextPtr, infoPtr = infoPtr->nextPtr) {
@@ -2357,12 +2689,13 @@ Tcl_WaitPid(pid, statPtr, options)
break;
}
}
+ Tcl_MutexUnlock(&procMutex);
/*
* 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;
@@ -2426,18 +2759,18 @@ Tcl_WaitPid(pid, statPtr, options)
/* 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_PidObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST *objv) /* Argument strings. */
{
Tcl_Channel chan;
Tcl_ChannelType *chanTypePtr;
PipeInfo *pipePtr;
int i;
Tcl_Obj *resultPtr;
- char buf[20];
+ char buf[TCL_INTEGER_SPACE];
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?channelId?");
@@ -2445,7 +2778,7 @@ Tcl_PidObjCmd(dummy, interp, objc, objv)
}
if (objc == 1) {
resultPtr = Tcl_GetObjResult(interp);
- sprintf(buf, "%lu", (unsigned long) getpid());
+ wsprintfA(buf, "%lu", (unsigned long) getpid());
Tcl_SetStringObj(resultPtr, buf, -1);
} else {
chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL),
@@ -2461,10 +2794,274 @@ Tcl_PidObjCmd(dummy, interp, objc, objv)
pipePtr = (PipeInfo *) Tcl_GetChannelInstanceData(chan);
resultPtr = Tcl_GetObjResult(interp);
for (i = 0; i < pipePtr->numPids; i++) {
- sprintf(buf, "%lu", TclpGetPid(pipePtr->pidPtr[i]));
+ wsprintfA(buf, "%lu", TclpGetPid(pipePtr->pidPtr[i]));
Tcl_ListObjAppendElement(/*interp*/ NULL, resultPtr,
Tcl_NewStringObj(buf, -1));
}
}
return TCL_OK;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * WaitForRead --
+ *
+ * Wait until some data is available, the pipe is at
+ * EOF or the reader thread is blocked waiting for data (if the
+ * channel is in non-blocking mode).
+ *
+ * Results:
+ * Returns 1 if pipe is readable. Returns 0 if there is no data
+ * on the pipe, but there is buffered data. Returns -1 if an
+ * error occurred. If an error occurred, the threads may not
+ * be synchronized.
+ *
+ * Side effects:
+ * Updates the shared state flags and may consume 1 byte of data
+ * from the pipe. If no error occurred, the reader thread is
+ * blocked waiting for a signal from the main thread.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+WaitForRead(
+ PipeInfo *infoPtr, /* Pipe state. */
+ int blocking) /* Indicates whether call should be
+ * blocking or not. */
+{
+ DWORD timeout, count;
+ HANDLE *handle = ((WinFile *) infoPtr->readFile)->handle;
+
+ while (1) {
+ /*
+ * Synchronize with the reader thread.
+ */
+
+ timeout = blocking ? INFINITE : 0;
+ if (WaitForSingleObject(infoPtr->readable, timeout) == WAIT_TIMEOUT) {
+ /*
+ * The reader thread is blocked waiting for data and the channel
+ * is in non-blocking mode.
+ */
+
+ errno = EAGAIN;
+ return -1;
+ }
+
+ /*
+ * At this point, the two threads are synchronized, so it is safe
+ * to access shared state.
+ */
+
+
+ /*
+ * If the pipe has hit EOF, it is always readable.
+ */
+
+ if (infoPtr->readFlags & PIPE_EOF) {
+ return 1;
+ }
+
+ /*
+ * Check to see if there is any data sitting in the pipe.
+ */
+
+ if (PeekNamedPipe(handle, (LPVOID) NULL, (DWORD) 0,
+ (LPDWORD) NULL, &count, (LPDWORD) NULL) != TRUE) {
+ TclWinConvertError(GetLastError());
+ /*
+ * Check to see if the peek failed because of EOF.
+ */
+
+ if (errno == EPIPE) {
+ infoPtr->readFlags |= PIPE_EOF;
+ return 1;
+ }
+
+ /*
+ * Ignore errors if there is data in the buffer.
+ */
+
+ if (infoPtr->readFlags & PIPE_EXTRABYTE) {
+ return 0;
+ } else {
+ return -1;
+ }
+ }
+
+ /*
+ * We found some data in the pipe, so it must be readable.
+ */
+
+ if (count > 0) {
+ return 1;
+ }
+
+ /*
+ * The pipe isn't readable, but there is some data sitting
+ * in the buffer, so return immediately.
+ */
+
+ if (infoPtr->readFlags & PIPE_EXTRABYTE) {
+ return 0;
+ }
+
+ /*
+ * There wasn't any data available, so reset the thread and
+ * try again.
+ */
+
+ ResetEvent(infoPtr->readable);
+ SetEvent(infoPtr->startReader);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * PipeReaderThread --
+ *
+ * This function runs in a separate thread and waits for input
+ * to become available on a pipe.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Signals the main thread when input become available. May
+ * cause the main thread to wake up by posting a message. May
+ * consume one byte from the pipe for each wait operation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static DWORD WINAPI
+PipeReaderThread(LPVOID arg)
+{
+ PipeInfo *infoPtr = (PipeInfo *)arg;
+ HANDLE *handle = ((WinFile *) infoPtr->readFile)->handle;
+ DWORD count;
+
+ for (;;) {
+ /*
+ * Wait for the main thread to signal before attempting to wait.
+ */
+
+ WaitForSingleObject(infoPtr->startReader, INFINITE);
+
+ /*
+ * Try waiting for 0 bytes. This will block until some data is
+ * available on NT, but will return immediately on Win 95. So,
+ * if no data is available after the first read, we block until
+ * we can read a single byte off of the pipe.
+ */
+
+ if ((ReadFile(handle, NULL, 0, &count, NULL) == FALSE)
+ || (PeekNamedPipe(handle, NULL, 0, NULL, &count,
+ NULL) == FALSE)) {
+ /*
+ * The error is a result of an EOF condition, so set the
+ * EOF bit before signalling the main thread.
+ */
+
+ if (GetLastError() == ERROR_BROKEN_PIPE) {
+ infoPtr->readFlags |= PIPE_EOF;
+ }
+ } else if (count == 0) {
+ if (ReadFile(handle, &(infoPtr->extraByte), 1, &count, NULL)
+ != FALSE) {
+ /*
+ * One byte was consumed as a side effect of waiting
+ * for the pipe to become readable.
+ */
+
+ infoPtr->readFlags |= PIPE_EXTRABYTE;
+ } else {
+ DWORD err;
+ err = GetLastError();
+ if (err == ERROR_BROKEN_PIPE) {
+ /*
+ * The error is a result of an EOF condition, so set the
+ * EOF bit before signalling the main thread.
+ */
+
+ infoPtr->readFlags |= PIPE_EOF;
+ }
+ }
+ }
+
+ /*
+ * Signal the main thread by signalling the readable event and
+ * then waking up the notifier thread.
+ */
+
+ SetEvent(infoPtr->readable);
+ Tcl_ThreadAlert(infoPtr->threadId);
+ }
+ return 0; /* NOT REACHED */
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * PipeWriterThread --
+ *
+ * This function runs in a separate thread and writes data
+ * onto a pipe.
+ *
+ * Results:
+ * Always returns 0.
+ *
+ * Side effects:
+ * Signals the main thread when an output operation is completed.
+ * May cause the main thread to wake up by posting a message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static DWORD WINAPI
+PipeWriterThread(LPVOID arg)
+{
+
+ PipeInfo *infoPtr = (PipeInfo *)arg;
+ HANDLE *handle = ((WinFile *) infoPtr->writeFile)->handle;
+ DWORD count, toWrite;
+ char *buf;
+
+ for (;;) {
+ /*
+ * Wait for the main thread to signal before attempting to write.
+ */
+
+ WaitForSingleObject(infoPtr->startWriter, INFINITE);
+
+ buf = infoPtr->writeBuf;
+ toWrite = infoPtr->toWrite;
+
+ /*
+ * Loop until all of the bytes are written or an error occurs.
+ */
+
+ while (toWrite > 0) {
+ if (WriteFile(handle, buf, toWrite, &count, NULL) == FALSE) {
+ infoPtr->writeError = GetLastError();
+ break;
+ } else {
+ toWrite -= count;
+ buf += count;
+ }
+ }
+
+ /*
+ * Signal the main thread by signalling the writable event and
+ * then waking up the notifier thread.
+ */
+
+ SetEvent(infoPtr->writable);
+ Tcl_ThreadAlert(infoPtr->threadId);
+ }
+ return 0; /* NOT REACHED */
+}
+
diff --git a/win/tclWinPort.h b/win/tclWinPort.h
index 99183cd..7452739 100644
--- a/win/tclWinPort.h
+++ b/win/tclWinPort.h
@@ -5,32 +5,58 @@
* 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.
+ * 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: @(#) tclWinPort.h 1.53 97/07/30 14:12:17
+ * SCCS: @(#) tclWinPort.h 1.62 98/02/18 14:00:22
*/
#ifndef _TCLWINPORT
#define _TCLWINPORT
-#include <malloc.h>
-#include <stdio.h>
+#ifndef _TCLINT
+# include "tclInt.h"
+#endif
+
+#ifdef CHECK_UNICODE_CALLS
+
+#define _UNICODE
+#define UNICODE
+
+#define __TCHAR_DEFINED
+typedef float *_TCHAR;
+#define _TCHAR_DEFINED
+typedef float *TCHAR;
+
+#endif
+
+/*
+ *---------------------------------------------------------------------------
+ * The following sets of #includes and #ifdefs are required to get Tcl to
+ * compile under the windows compilers.
+ *---------------------------------------------------------------------------
+ */
+
+#include <stdio.h>
#include <stdlib.h>
-#include <string.h>
+
+#include <direct.h>
#include <errno.h>
+#include <fcntl.h>
+#include <float.h>
+#include <io.h>
+#include <malloc.h>
#include <process.h>
#include <signal.h>
-#include <winsock.h>
+#include <string.h>
#include <sys/stat.h>
#include <sys/timeb.h>
+#include <tchar.h>
#include <time.h>
-#include <io.h>
-#include <fcntl.h>
-#include <float.h>
+#include <winsock.h>
#define WIN32_LEAN_AND_MEAN
#include <windows.h>
@@ -53,27 +79,112 @@
#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.
+ * The following defines redefine the Windows Socket errors as
+ * BSD errors so Tcl_PosixError can do the right thing.
*/
-#define TCL_SHLIB_EXT ".dll"
+#ifndef EWOULDBLOCK
+#define EWOULDBLOCK EAGAIN
+#endif
+#ifndef EALREADY
+#define EALREADY 149 /* operation already in progress */
+#endif
+#ifndef ENOTSOCK
+#define ENOTSOCK 95 /* Socket operation on non-socket */
+#endif
+#ifndef EDESTADDRREQ
+#define EDESTADDRREQ 96 /* Destination address required */
+#endif
+#ifndef EMSGSIZE
+#define EMSGSIZE 97 /* Message too long */
+#endif
+#ifndef EPROTOTYPE
+#define EPROTOTYPE 98 /* Protocol wrong type for socket */
+#endif
+#ifndef ENOPROTOOPT
+#define ENOPROTOOPT 99 /* Protocol not available */
+#endif
+#ifndef EPROTONOSUPPORT
+#define EPROTONOSUPPORT 120 /* Protocol not supported */
+#endif
+#ifndef ESOCKTNOSUPPORT
+#define ESOCKTNOSUPPORT 121 /* Socket type not supported */
+#endif
+#ifndef EOPNOTSUPP
+#define EOPNOTSUPP 122 /* Operation not supported on socket */
+#endif
+#ifndef EPFNOSUPPORT
+#define EPFNOSUPPORT 123 /* Protocol family not supported */
+#endif
+#ifndef EAFNOSUPPORT
+#define EAFNOSUPPORT 124 /* Address family not supported */
+#endif
+#ifndef EADDRINUSE
+#define EADDRINUSE 125 /* Address already in use */
+#endif
+#ifndef EADDRNOTAVAIL
+#define EADDRNOTAVAIL 126 /* Can't assign requested address */
+#endif
+#ifndef ENETDOWN
+#define ENETDOWN 127 /* Network is down */
+#endif
+#ifndef ENETUNREACH
+#define ENETUNREACH 128 /* Network is unreachable */
+#endif
+#ifndef ENETRESET
+#define ENETRESET 129 /* Network dropped connection on reset */
+#endif
+#ifndef ECONNABORTED
+#define ECONNABORTED 130 /* Software caused connection abort */
+#endif
+#ifndef ECONNRESET
+#define ECONNRESET 131 /* Connection reset by peer */
+#endif
+#ifndef ENOBUFS
+#define ENOBUFS 132 /* No buffer space available */
+#endif
+#ifndef EISCONN
+#define EISCONN 133 /* Socket is already connected */
+#endif
+#ifndef ENOTCONN
+#define ENOTCONN 134 /* Socket is not connected */
+#endif
+#ifndef ESHUTDOWN
+#define ESHUTDOWN 143 /* Can't send after socket shutdown */
+#endif
+#ifndef ETOOMANYREFS
+#define ETOOMANYREFS 144 /* Too many references: can't splice */
+#endif
+#ifndef ETIMEDOUT
+#define ETIMEDOUT 145 /* Connection timed out */
+#endif
+#ifndef ECONNREFUSED
+#define ECONNREFUSED 146 /* Connection refused */
+#endif
+#ifndef ELOOP
+#define ELOOP 90 /* Symbolic link loop */
+#endif
+#ifndef EHOSTDOWN
+#define EHOSTDOWN 147 /* Host is down */
+#endif
+#ifndef EHOSTUNREACH
+#define EHOSTUNREACH 148 /* No route to host */
+#endif
+#ifndef ENOTEMPTY
+#define ENOTEMPTY 93 /* directory not empty */
+#endif
+#ifndef EUSERS
+#define EUSERS 94 /* Too many users (for UFS) */
+#endif
+#ifndef EDQUOT
+#define EDQUOT 49 /* Disc quota exceeded */
+#endif
+#ifndef ESTALE
+#define ESTALE 151 /* Stale NFS file handle */
+#endif
+#ifndef EREMOTE
+#define EREMOTE 66 /* The object is remote */
+#endif
/*
* Supply definitions for macros to query wait status, if not already
@@ -123,17 +234,9 @@
#endif
/*
- * Define MAXPATHLEN in terms of MAXPATH if available
+ * Define access mode constants if they aren't already defined.
*/
-#ifndef MAXPATH
-#define MAXPATH MAX_PATH
-#endif /* MAXPATH */
-
-#ifndef MAXPATHLEN
-#define MAXPATHLEN MAXPATH
-#endif /* MAXPATHLEN */
-
#ifndef F_OK
# define F_OK 00
#endif
@@ -189,6 +292,18 @@
# endif
/*
+ * Define MAXPATHLEN in terms of MAXPATH if available
+ */
+
+#ifndef MAXPATH
+#define MAXPATH MAX_PATH
+#endif /* MAXPATH */
+
+#ifndef MAXPATHLEN
+#define MAXPATHLEN MAXPATH
+#endif /* MAXPATHLEN */
+
+/*
* Define pid_t and uid_t if they're not already defined.
*/
@@ -200,12 +315,6 @@
#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().
@@ -219,112 +328,24 @@
#endif /* _MSC_VER */
/*
- * The following defines redefine the Windows Socket errors as
- * BSD errors so Tcl_PosixError can do the right thing.
+ *---------------------------------------------------------------------------
+ * The following macros and declarations represent the interface between
+ * generic and windows-specific parts of Tcl. Some of the macros may
+ * override functions declared in tclInt.h.
+ *---------------------------------------------------------------------------
*/
-#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 default platform eol translation on Windows is TCL_TRANSLATE_CRLF:
+ */
+
+#define TCL_PLATFORM_TRANSLATION TCL_TRANSLATE_CRLF
+
+/*
+ * Declare dynamic loading extension macro.
+ */
+
+#define TCL_SHLIB_EXT ".dll"
/*
* The following define ensures that we use the native putenv
@@ -333,7 +354,28 @@
*/
#define USE_PUTENV 1
-
+
+/*
+ * 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 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 size_t TclStrftime _ANSI_ARGS_((char *s, size_t maxsize,
+ const char *format, const struct tm *t));
+
/*
* The following defines map from standard socket names to our internal
* wrappers that redirect through the winSock function table (see the
@@ -346,41 +388,35 @@
#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.
+ * The following macros have trivial definitions, allowing generic code to
+ * address platform-specific issues.
*/
-#define stat(path, buf) TclWinStat(path, buf)
-#define lstat stat
-#define access(path, mode) TclWinAccess(path, mode)
+#define TclpReleaseFile(file) ckfree((char *) file)
-EXTERN int TclWinStat _ANSI_ARGS_((CONST char *path,
- struct stat *buf));
-EXTERN int TclWinAccess _ANSI_ARGS_((CONST char *path,
- int mode));
+/*
+ * The following macros and declarations wrap the C runtime library
+ * functions.
+ */
-#define TclpReleaseFile(file) ckfree((char *) file)
+#define TclpExit exit
+#define TclpLstat TclpStat
+
+EXTERN int TclpStat _ANSI_ARGS_((CONST char *path,
+ struct stat *buf));
/*
- * Declarations for Windows specific functions.
+ * Declarations for Windows-only functions.
*/
EXTERN void TclWinConvertError _ANSI_ARGS_((DWORD errCode));
@@ -391,9 +427,28 @@ EXTERN struct servent * PASCAL FAR
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));
+
+/*
+ * Platform specific mutex definition used by memory allocators.
+ * These mutexes are statically allocated and explicitly initialized.
+ * Most modules do not use this, but instead use Tcl_Mutex types and
+ * Tcl_MutexLock and Tcl_MutexUnlock that are self-initializing.
+ */
+
+#ifdef TCL_THREADS
+typedef CRITICAL_SECTION TclpMutex;
+EXTERN void TclpMutexInit _ANSI_ARGS_((TclpMutex *mPtr));
+EXTERN void TclpMutexLock _ANSI_ARGS_((TclpMutex *mPtr));
+EXTERN void TclpMutexUnlock _ANSI_ARGS_((TclpMutex *mPtr));
+#else
+typedef int TclpMutex;
+#define TclpMutexInit(a)
+#define TclpMutexLock(a)
+#define TclpMutexUnlock(a)
+#endif /* TCL_THREADS */
+
#endif /* _TCLWINPORT */
diff --git a/win/tclWinReg.c b/win/tclWinReg.c
index 5e5d450..718aa65 100644
--- a/win/tclWinReg.c
+++ b/win/tclWinReg.c
@@ -10,7 +10,7 @@
* 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
+ * SCCS: @(#) tclWinReg.c 1.12 98/02/11 17:41:21
*/
#include <tcl.h>
@@ -1145,36 +1145,65 @@ AppendSystemError(
DWORD error) /* Result code from error. */
{
int length;
- char *msgbuf, id[10];
+ WCHAR *wMsgPtr;
+ char *msg;
+ char id[TCL_INTEGER_SPACE], msgBuf[24 + TCL_INTEGER_SPACE];
+ Tcl_DString ds;
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
- sprintf(id, "%d", error);
- length = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM
+ length = FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM
| FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error,
- MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (LPTSTR)&msgbuf,
+ MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (WCHAR *) &wMsgPtr,
0, NULL);
if (length == 0) {
+ char *msgPtr;
+
+ length = FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM
+ | FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error,
+ MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (char *) &msgPtr,
+ 0, NULL);
+ if (length > 0) {
+ wMsgPtr = (WCHAR *) LocalAlloc(LPTR, (length + 1) * sizeof(WCHAR));
+ MultiByteToWideChar(CP_ACP, 0, msgPtr, length + 1, wMsgPtr,
+ length + 1);
+ LocalFree(msgPtr);
+ }
+ }
+ if (length == 0) {
if (error == ERROR_CALL_NOT_IMPLEMENTED) {
- msgbuf = "function not supported under Win32s";
+ msg = "function not supported under Win32s";
} else {
- msgbuf = id;
+ sprintf(msgBuf, "unknown error: %d", error);
+ msg = msgBuf;
}
} else {
+ Tcl_Encoding encoding;
+
+ encoding = Tcl_GetEncoding(NULL, "unicode");
+ Tcl_ExternalToUtfDString(encoding, (char *) wMsgPtr, -1, &ds);
+ Tcl_FreeEncoding(encoding);
+ LocalFree(wMsgPtr);
+
+ msg = Tcl_DStringValue(&ds);
+ length = Tcl_DStringLength(&ds);
+
/*
* Trim the trailing CR/LF from the system message.
*/
- if (msgbuf[length-1] == '\n') {
- msgbuf[--length] = 0;
+ if (msg[length-1] == '\n') {
+ msg[--length] = 0;
}
- if (msgbuf[length-1] == '\r') {
- msgbuf[--length] = 0;
+ if (msg[length-1] == '\r') {
+ msg[--length] = 0;
}
}
- Tcl_SetErrorCode(interp, "WINDOWS", id, msgbuf, (char *) NULL);
- Tcl_AppendToObj(resultPtr, msgbuf, -1);
+
+ sprintf(id, "%d", error);
+ Tcl_SetErrorCode(interp, "WINDOWS", id, msg, (char *) NULL);
+ Tcl_AppendToObj(resultPtr, msg, length);
if (length != 0) {
- LocalFree(msgbuf);
+ Tcl_DStringFree(&ds);
}
}
diff --git a/win/tclWinSock.c b/win/tclWinSock.c
index bd81d2d..c6e6273 100644
--- a/win/tclWinSock.c
+++ b/win/tclWinSock.c
@@ -8,11 +8,10 @@
* 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
+ * SCCS: @(#) tclWinSock.c 1.93 98/02/19 15:21:32
*/
-#include "tclInt.h"
-#include "tclPort.h"
+#include "tclWinInt.h"
/*
* The following variable is used to tell whether this module has been
@@ -24,6 +23,7 @@ static int initialized = 0;
static int hostnameInitialized = 0;
static char hostname[255]; /* This buffer should be big enough for
* hostname plus domain name. */
+static Tcl_Mutex socketMutex;
/*
* The following structure contains pointers to all of the WinSock API entry
@@ -139,11 +139,15 @@ typedef struct SocketEvent {
#define SOCKET_PENDING (1<<3) /* A message has been sent
* for this socket */
-/*
- * Every open socket has an entry on the following list.
- */
+typedef struct ThreadSpecificData {
+ /*
+ * Every open socket has an entry on the following list.
+ */
+
+ SocketInfo *socketList;
+} ThreadSpecificData;
-static SocketInfo *socketList;
+static Tcl_ThreadDataKey dataKey;
/*
* Static functions defined in this file.
@@ -166,6 +170,8 @@ static LRESULT CALLBACK SocketProc _ANSI_ARGS_((HWND hwnd, UINT message,
WPARAM wParam, LPARAM lParam));
static void SocketSetupProc _ANSI_ARGS_((ClientData clientData,
int flags));
+static void SocketThreadExitHandler _ANSI_ARGS_((ClientData clientData));
+static int SocketsEnabled _ANSI_ARGS_((void));
static void TcpAccept _ANSI_ARGS_((SocketInfo *infoPtr));
static int TcpBlockProc _ANSI_ARGS_((ClientData instanceData,
int mode));
@@ -218,6 +224,8 @@ static Tcl_ChannelType tcpChannelType = {
* library and set up the winSock function table. If successful,
* registers the event window for the socket notifier code.
*
+ * Assumes Mutex is held.
+ *
* Results:
* None.
*
@@ -234,181 +242,195 @@ 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;
- }
+ WNDCLASSA class;
+ ThreadSpecificData *tsdPtr =
+ (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
- /*
- * 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;
- }
+ if (! initialized) {
+ initialized = 1;
+ Tcl_CreateExitHandler(SocketExitHandler, (ClientData) NULL);
- /*
- * 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;
+ /*
+ * 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)
+ || (SearchPathA(NULL, "WINSOCK", ".DLL", 0, NULL, NULL) != 0)) {
+ winSock.hInstance = LoadLibraryA("wsock32.dll");
+ } else {
+ winSock.hInstance = NULL;
+ }
+
+ /*
+ * Initialize the function table.
+ */
+
+ if (!SocketsEnabled()) {
+ return;
+ }
+
+ winSock.accept = (SOCKET (PASCAL FAR *)(SOCKET s,
+ struct sockaddr FAR *addr, int FAR *addrlen))
+ GetProcAddress(winSock.hInstance, "accept");
+ winSock.bind = (int (PASCAL FAR *)(SOCKET s,
+ const struct sockaddr FAR *addr, int namelen))
+ GetProcAddress(winSock.hInstance, "bind");
+ winSock.closesocket = (int (PASCAL FAR *)(SOCKET s))
+ GetProcAddress(winSock.hInstance, "closesocket");
+ winSock.connect = (int (PASCAL FAR *)(SOCKET s,
+ const struct sockaddr FAR *name, int namelen))
+ GetProcAddress(winSock.hInstance, "connect");
+ winSock.ioctlsocket = (int (PASCAL FAR *)(SOCKET s, long cmd,
+ u_long FAR *argp)) GetProcAddress(winSock.hInstance, "ioctlsocket");
+ winSock.getsockopt = (int (PASCAL FAR *)(SOCKET s,
+ int level, int optname, char FAR * optval, int FAR *optlen))
+ GetProcAddress(winSock.hInstance, "getsockopt");
+ winSock.htons = (u_short (PASCAL FAR *)(u_short hostshort))
+ GetProcAddress(winSock.hInstance, "htons");
+ winSock.inet_addr = (unsigned long (PASCAL FAR *)(const char FAR *cp))
+ GetProcAddress(winSock.hInstance, "inet_addr");
+ winSock.inet_ntoa = (char FAR * (PASCAL FAR *)(struct in_addr in))
+ GetProcAddress(winSock.hInstance, "inet_ntoa");
+ winSock.listen = (int (PASCAL FAR *)(SOCKET s, int backlog))
+ GetProcAddress(winSock.hInstance, "listen");
+ winSock.ntohs = (u_short (PASCAL FAR *)(u_short netshort))
+ GetProcAddress(winSock.hInstance, "ntohs");
+ winSock.recv = (int (PASCAL FAR *)(SOCKET s, char FAR * buf,
+ int len, int flags)) GetProcAddress(winSock.hInstance, "recv");
+ winSock.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 (RegisterClassA(&class)) {
+ winSock.hwnd = CreateWindowA("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;
+ }
}
/*
- * 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.
+ * Check for per-thread initialization.
*/
- 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;
+ if (tsdPtr == NULL) {
+ tsdPtr = TCL_TSD_INIT(&dataKey);
+ tsdPtr->socketList = NULL;
+ Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL);
+ Tcl_CreateThreadExitHandler(SocketThreadExitHandler, NULL);
}
- Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL);
return;
unloadLibrary:
@@ -420,6 +442,34 @@ unloadLibrary:
/*
*----------------------------------------------------------------------
*
+ * SocketsEnabled --
+ *
+ * Check that the WinSock DLL is loaded and ready.
+ *
+ * Results:
+ * 1 if it is.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+static int
+SocketsEnabled()
+{
+ int enabled;
+ Tcl_MutexLock(&socketMutex);
+ enabled = (winSock.hInstance != NULL);
+ Tcl_MutexUnlock(&socketMutex);
+ return enabled;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
* SocketExitHandler --
*
* Callback invoked during exit clean up to delete the socket
@@ -439,22 +489,48 @@ static void
SocketExitHandler(clientData)
ClientData clientData; /* Not used. */
{
+ Tcl_MutexLock(&socketMutex);
if (winSock.hInstance) {
DestroyWindow(winSock.hwnd);
- UnregisterClass("TclSocket", TclWinGetTclInstance());
+ UnregisterClassA("TclSocket", TclWinGetTclInstance());
(*winSock.WSACleanup)();
FreeLibrary(winSock.hInstance);
winSock.hInstance = NULL;
}
- Tcl_DeleteEventSource(SocketSetupProc, SocketCheckProc, NULL);
initialized = 0;
hostnameInitialized = 0;
+ Tcl_MutexUnlock(&socketMutex);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SocketThreadExitHandler --
+ *
+ * Callback invoked during thread clean up to delete the socket
+ * event source.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Delete the event source.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+static void
+SocketThreadExitHandler(clientData)
+ ClientData clientData; /* Not used. */
+{
+ Tcl_DeleteEventSource(SocketSetupProc, SocketCheckProc, NULL);
}
/*
*----------------------------------------------------------------------
*
- * TclHasSockets --
+ * TclpHasSockets --
*
* This function determines whether sockets are available on the
* current system and returns an error in interp if they are not.
@@ -471,14 +547,14 @@ SocketExitHandler(clientData)
*/
int
-TclHasSockets(interp)
+TclpHasSockets(interp)
Tcl_Interp *interp;
{
- if (!initialized) {
- InitSockets();
- }
-
- if (winSock.hInstance != NULL) {
+ Tcl_MutexLock(&socketMutex);
+ InitSockets();
+ Tcl_MutexUnlock(&socketMutex);
+
+ if (SocketsEnabled()) {
return TCL_OK;
}
if (interp != NULL) {
@@ -512,6 +588,7 @@ SocketSetupProc(data, flags)
{
SocketInfo *infoPtr;
Tcl_Time blockTime = { 0, 0 };
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!(flags & TCL_FILE_EVENTS)) {
return;
@@ -521,7 +598,8 @@ SocketSetupProc(data, flags)
* Check to see if there is a ready socket. If so, poll.
*/
- for (infoPtr = socketList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
+ for (infoPtr = tsdPtr->socketList; infoPtr != NULL;
+ infoPtr = infoPtr->nextPtr) {
if (infoPtr->readyEvents & infoPtr->watchEvents) {
Tcl_SetMaxBlockTime(&blockTime);
break;
@@ -553,6 +631,7 @@ SocketCheckProc(data, flags)
{
SocketInfo *infoPtr;
SocketEvent *evPtr;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!(flags & TCL_FILE_EVENTS)) {
return;
@@ -564,7 +643,8 @@ SocketCheckProc(data, flags)
* events).
*/
- for (infoPtr = socketList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
+ for (infoPtr = tsdPtr->socketList; infoPtr != NULL;
+ infoPtr = infoPtr->nextPtr) {
if ((infoPtr->readyEvents & infoPtr->watchEvents)
&& !(infoPtr->flags & SOCKET_PENDING)) {
infoPtr->flags |= SOCKET_PENDING;
@@ -608,6 +688,7 @@ SocketEventProc(evPtr, flags)
int mask = 0;
u_long nBytes;
int status, events;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!(flags & TCL_FILE_EVENTS)) {
return 0;
@@ -617,7 +698,8 @@ SocketEventProc(evPtr, flags)
* Find the specified socket on the socket list.
*/
- for (infoPtr = socketList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
+ for (infoPtr = tsdPtr->socketList; infoPtr != NULL;
+ infoPtr = infoPtr->nextPtr) {
if (infoPtr->socket == eventPtr->socket) {
break;
}
@@ -670,9 +752,10 @@ SocketEventProc(evPtr, flags)
* could have consumed the data in the meantime.
*/
+ nBytes = 0;
status = (*winSock.ioctlsocket)(infoPtr->socket, FIONREAD,
&nBytes);
- if (status != SOCKET_ERROR && nBytes > 0) {
+ if ((status != SOCKET_ERROR) && (nBytes > 0)) {
mask |= TCL_READABLE;
} else {
/*
@@ -762,6 +845,7 @@ TcpCloseProc(instanceData, interp)
SocketInfo *infoPtr = (SocketInfo *) instanceData;
SocketInfo **nextPtrPtr;
int errorCode = 0;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* Check that WinSock is initialized; do not call it if not, to
@@ -770,7 +854,7 @@ TcpCloseProc(instanceData, interp)
* use sockets.
*/
- if (winSock.hInstance != NULL) {
+ if (SocketsEnabled()) {
/*
* Clean up the OS socket handle. The default Windows setting
@@ -788,13 +872,14 @@ TcpCloseProc(instanceData, interp)
* Remove the socket from socketList.
*/
- for (nextPtrPtr = &socketList; (*nextPtrPtr) != NULL;
+ for (nextPtrPtr = &(tsdPtr->socketList); (*nextPtrPtr) != NULL;
nextPtrPtr = &((*nextPtrPtr)->nextPtr)) {
if ((*nextPtrPtr) == infoPtr) {
(*nextPtrPtr) = infoPtr->nextPtr;
break;
}
}
+
ckfree((char *) infoPtr);
return errorCode;
}
@@ -821,6 +906,7 @@ NewSocketInfo(socket)
SOCKET socket;
{
SocketInfo *infoPtr;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
infoPtr = (SocketInfo *) ckalloc((unsigned) sizeof(SocketInfo));
infoPtr->socket = socket;
@@ -830,8 +916,10 @@ NewSocketInfo(socket)
infoPtr->selectEvents = 0;
infoPtr->acceptProc = NULL;
infoPtr->lastError = 0;
- infoPtr->nextPtr = socketList;
- socketList = infoPtr;
+
+ infoPtr->nextPtr = tsdPtr->socketList;
+ tsdPtr->socketList = infoPtr;
+
return infoPtr;
}
@@ -878,11 +966,11 @@ CreateSocket(interp, port, host, server, myaddr, myport, async)
* handler for WinSock ran before other exit handlers that want to
* use sockets.
*/
-
- if (winSock.hInstance == NULL) {
+
+ if (!SocketsEnabled()) {
return NULL;
}
-
+
if (! CreateSocketAddress(&sockaddr, host, port)) {
goto error;
}
@@ -1056,11 +1144,11 @@ CreateSocketAddress(sockaddrPtr, host, port)
* use sockets.
*/
- if (winSock.hInstance == NULL) {
+ if (!SocketsEnabled()) {
Tcl_SetErrno(EFAULT);
return 0;
}
-
+
(void) memset((char *) sockaddrPtr, '\0', sizeof(struct sockaddr_in));
sockaddrPtr->sin_family = AF_INET;
sockaddrPtr->sin_port = (*winSock.htons)((short) (port & 0xFFFF));
@@ -1209,9 +1297,9 @@ Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async)
* client socket asynchronously. */
{
SocketInfo *infoPtr;
- char channelName[20];
+ char channelName[16 + TCL_INTEGER_SPACE];
- if (TclHasSockets(interp) != TCL_OK) {
+ if (TclpHasSockets(interp) != TCL_OK) {
return NULL;
}
@@ -1224,7 +1312,7 @@ Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async)
return NULL;
}
- sprintf(channelName, "sock%d", infoPtr->socket);
+ wsprintfA(channelName, "sock%d", infoPtr->socket);
infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
(ClientData) infoPtr, (TCL_READABLE | TCL_WRITABLE));
@@ -1264,9 +1352,9 @@ Tcl_MakeTcpClientChannel(sock)
ClientData sock; /* The socket to wrap up into a channel. */
{
SocketInfo *infoPtr;
- char channelName[20];
+ char channelName[16 + TCL_INTEGER_SPACE];
- if (TclHasSockets(NULL) != TCL_OK) {
+ if (TclpHasSockets(NULL) != TCL_OK) {
return NULL;
}
@@ -1286,7 +1374,7 @@ Tcl_MakeTcpClientChannel(sock)
(void) (*winSock.WSAAsyncSelect)(infoPtr->socket, winSock.hwnd,
SOCKET_MESSAGE, infoPtr->selectEvents);
- sprintf(channelName, "sock%d", infoPtr->socket);
+ wsprintfA(channelName, "sock%d", infoPtr->socket);
infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
(ClientData) infoPtr, (TCL_READABLE | TCL_WRITABLE));
Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto crlf");
@@ -1321,9 +1409,9 @@ Tcl_OpenTcpServer(interp, port, host, acceptProc, acceptProcData)
ClientData acceptProcData; /* Data for the callback. */
{
SocketInfo *infoPtr;
- char channelName[20];
+ char channelName[16 + TCL_INTEGER_SPACE];
- if (TclHasSockets(interp) != TCL_OK) {
+ if (TclpHasSockets(interp) != TCL_OK) {
return NULL;
}
@@ -1339,7 +1427,7 @@ Tcl_OpenTcpServer(interp, port, host, acceptProc, acceptProcData)
infoPtr->acceptProc = acceptProc;
infoPtr->acceptProcData = acceptProcData;
- sprintf(channelName, "sock%d", infoPtr->socket);
+ wsprintfA(channelName, "sock%d", infoPtr->socket);
infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
(ClientData) infoPtr, 0);
@@ -1377,7 +1465,7 @@ TcpAccept(infoPtr)
SocketInfo *newInfoPtr;
struct sockaddr_in addr;
int len;
- char channelName[20];
+ char channelName[16 + TCL_INTEGER_SPACE];
/*
* Accept the incoming connection request.
@@ -1413,7 +1501,7 @@ TcpAccept(infoPtr)
(void) (*winSock.WSAAsyncSelect)(newInfoPtr->socket, winSock.hwnd,
SOCKET_MESSAGE, newInfoPtr->selectEvents);
- sprintf(channelName, "sock%d", newInfoPtr->socket);
+ wsprintfA(channelName, "sock%d", newInfoPtr->socket);
newInfoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
(ClientData) newInfoPtr, (TCL_READABLE | TCL_WRITABLE));
if (Tcl_SetChannelOption(NULL, newInfoPtr->channel, "-translation",
@@ -1475,7 +1563,7 @@ TcpInputProc(instanceData, buf, toRead, errorCodePtr)
* use sockets.
*/
- if (winSock.hInstance == NULL) {
+ if (!SocketsEnabled()) {
*errorCodePtr = EFAULT;
return -1;
}
@@ -1596,11 +1684,11 @@ TcpOutputProc(instanceData, buf, toWrite, errorCodePtr)
* use sockets.
*/
- if (winSock.hInstance == NULL) {
+ if (! SocketsEnabled()) {
*errorCodePtr = EFAULT;
return -1;
}
-
+
/*
* Check to see if the socket is connected before trying to write.
*/
@@ -1698,7 +1786,7 @@ TcpGetOptionProc(instanceData, interp, optionName, dsPtr)
SOCKET sock;
int size = sizeof(struct sockaddr_in);
size_t len = 0;
- char buf[128];
+ char buf[TCL_INTEGER_SPACE];
/*
* Check that WinSock is initialized; do not call it if not, to
@@ -1707,7 +1795,7 @@ TcpGetOptionProc(instanceData, interp, optionName, dsPtr)
* use sockets.
*/
- if (winSock.hInstance == NULL) {
+ if (!SocketsEnabled()) {
if (interp) {
Tcl_AppendResult(interp, "winsock is not initialized", NULL);
}
@@ -1740,7 +1828,7 @@ TcpGetOptionProc(instanceData, interp, optionName, dsPtr)
Tcl_DStringAppendElement(dsPtr,
(*winSock.inet_ntoa)(peername.sin_addr));
}
- sprintf(buf, "%d", (*winSock.ntohs)(peername.sin_port));
+ TclFormatInt(buf, (*winSock.ntohs)(peername.sin_port));
Tcl_DStringAppendElement(dsPtr, buf);
if (len == 0) {
Tcl_DStringEndSublist(dsPtr);
@@ -1786,7 +1874,7 @@ TcpGetOptionProc(instanceData, interp, optionName, dsPtr)
Tcl_DStringAppendElement(dsPtr,
(*winSock.inet_ntoa)(sockname.sin_addr));
}
- sprintf(buf, "%d", (*winSock.ntohs)(sockname.sin_port));
+ TclFormatInt(buf, (*winSock.ntohs)(sockname.sin_port));
Tcl_DStringAppendElement(dsPtr, buf);
if (len == 0) {
Tcl_DStringEndSublist(dsPtr);
@@ -1919,6 +2007,7 @@ SocketProc(hwnd, message, wParam, lParam)
int event, error;
SOCKET socket;
SocketInfo *infoPtr;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (message != SOCKET_MESSAGE) {
return DefWindowProc(hwnd, message, wParam, lParam);
@@ -1933,7 +2022,8 @@ SocketProc(hwnd, message, wParam, lParam)
* eventState flag.
*/
- for (infoPtr = socketList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
+ for (infoPtr = tsdPtr->socketList; infoPtr != NULL;
+ infoPtr = infoPtr->nextPtr) {
if (infoPtr->socket == socket) {
/*
* Update the socket state.
@@ -1997,29 +2087,42 @@ char *
Tcl_GetHostName()
{
DWORD length;
- char *p;
+ WCHAR wbuf[MAX_COMPUTERNAME_LENGTH + 1];
+ Tcl_MutexLock(&socketMutex);
if (hostnameInitialized) {
+ Tcl_MutexUnlock(&socketMutex);
return hostname;
}
- if (TclHasSockets(NULL) == TCL_OK) {
+ if (TclpHasSockets(NULL) == TCL_OK) {
+ /*
+ * INTL: bug
+ */
+
if ((*winSock.gethostname)(hostname, sizeof(hostname)) == 0) {
hostnameInitialized = 1;
+ Tcl_MutexUnlock(&socketMutex);
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));
- }
- }
+ if ((*tclWinProcs->getComputerNameProc)(wbuf, &length) != 0) {
+ /*
+ * Convert string from native to UTF then change to lowercase.
+ */
+
+ Tcl_DString ds;
+
+ lstrcpynA(hostname, Tcl_WinTCharToUtf((TCHAR *) wbuf, -1, &ds),
+ sizeof(hostname));
+ Tcl_DStringFree(&ds);
+ Tcl_UtfToLower(hostname);
} else {
hostname[0] = '\0';
}
hostnameInitialized = 1;
+ Tcl_MutexUnlock(&socketMutex);
return hostname;
}
@@ -2053,7 +2156,7 @@ TclWinGetSockOpt(SOCKET s, int level, int optname, char FAR * optval,
* use sockets.
*/
- if (winSock.hInstance == NULL) {
+ if (!SocketsEnabled()) {
return SOCKET_ERROR;
}
@@ -2070,8 +2173,7 @@ TclWinSetSockOpt(SOCKET s, int level, int optname, const char FAR * optval,
* handler for WinSock ran before other exit handlers that want to
* use sockets.
*/
-
- if (winSock.hInstance == NULL) {
+ if (!SocketsEnabled()) {
return SOCKET_ERROR;
}
@@ -2088,7 +2190,7 @@ TclWinNToHS(u_short netshort)
* use sockets.
*/
- if (winSock.hInstance == NULL) {
+ if (!SocketsEnabled()) {
return (u_short) -1;
}
@@ -2104,8 +2206,7 @@ TclWinGetServByName(const char FAR * name, const char FAR * proto)
* handler for WinSock ran before other exit handlers that want to
* use sockets.
*/
-
- if (winSock.hInstance == NULL) {
+ if (!SocketsEnabled()) {
return (struct servent FAR *) NULL;
}
diff --git a/win/tclWinTest.c b/win/tclWinTest.c
index cb61403..b4d7687 100644
--- a/win/tclWinTest.c
+++ b/win/tclWinTest.c
@@ -8,11 +8,10 @@
* 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
+ * SCCS: @(#) tclWinTest.c 1.3 97/07/28 15:27:32
*/
-#include "tclInt.h"
-#include "tclPort.h"
+#include "tclWinInt.h"
/*
* Forward declarations of procedures defined later in this file:
diff --git a/win/tclWinThrd.c b/win/tclWinThrd.c
new file mode 100644
index 0000000..f455d54
--- /dev/null
+++ b/win/tclWinThrd.c
@@ -0,0 +1,724 @@
+/*
+ * tclWinThread.c --
+ *
+ * This file implements the Windows-specific thread operations.
+ *
+ * Copyright (c) 1998 by Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclWinThrd.c 1.13 98/02/18 14:00:23
+ */
+
+#include "tclWinInt.h"
+
+#include <dos.h>
+#include <fcntl.h>
+#include <io.h>
+#include <sys/stat.h>
+
+/*
+ * This is the master lock used to serialize access to other
+ * serialization data structures.
+ */
+
+static CRITICAL_SECTION masterLock;
+static int init = 0;
+#define MASTER_LOCK EnterCriticalSection(&masterLock)
+#define MASTER_UNLOCK LeaveCriticalSection(&masterLock)
+
+/*
+ * This is the master lock used to serialize initialization and finalization
+ * of Tcl as a whole.
+ */
+
+static CRITICAL_SECTION initLock;
+
+/*
+ * This is a preallocated lock for use by memory allocators.
+ */
+
+static CRITICAL_SECTION allocLock;
+static Tcl_Mutex allocMutex;
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpThreadCreate --
+ *
+ * This procedure creates a new thread.
+ *
+ * Results:
+ * TCL_OK if the thread could be created. The thread ID is
+ * returned in a parameter.
+ *
+ * Side effects:
+ * A new thread is created.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclpThreadCreate(idPtr, proc, clientData)
+ Tcl_ThreadId *idPtr; /* Return, the ID of the thread */
+ Tcl_ThreadCreateProc proc; /* Main() function of the thread */
+ ClientData clientData; /* The one argument to Main() */
+{
+ HANDLE tHandle;
+
+ tHandle = CreateThread(NULL, 0, (LPTHREAD_START_ROUTINE) proc,
+ (DWORD *)clientData, 0, (DWORD *)idPtr);
+ if (tHandle == NULL) {
+ return TCL_ERROR;
+ } else {
+ return TCL_OK;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpThreadExit --
+ *
+ * This procedure terminates the current thread.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * This procedure terminates the current thread.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpThreadExit(status)
+ int status;
+{
+ ExitThread((DWORD)status);
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetCurrentThread --
+ *
+ * This procedure returns the ID of the currently running thread.
+ *
+ * Results:
+ * A thread ID.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_ThreadId
+Tcl_GetCurrentThread()
+{
+ return (Tcl_ThreadId)GetCurrentThreadId();
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpInitLock
+ *
+ * This procedure is used to grab a lock that serializes initialization
+ * and finalization of Tcl. On some platforms this may also initialize
+ * the mutex used to serialize creation of more mutexes and thread
+ * local storage keys.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Acquire the initialization mutex.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpInitLock()
+{
+ if (!init) {
+ /*
+ * There is a fundamental race here that is solved by creating
+ * the first Tcl interpreter in a single threaded environment.
+ * Once the interpreter has been created, it is safe to create
+ * more threads that create interpreters in parallel.
+ */
+ init = 1;
+ InitializeCriticalSection(&initLock);
+ InitializeCriticalSection(&masterLock);
+ }
+ EnterCriticalSection(&initLock);
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpInitUnlock
+ *
+ * This procedure is used to release a lock that serializes initialization
+ * and finalization of Tcl.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Release the initialization mutex.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpInitUnlock()
+{
+ LeaveCriticalSection(&initLock);
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpMasterLock
+ *
+ * This procedure is used to grab a lock that serializes creation
+ * of mutexes, condition variables, and thread local storage keys.
+ *
+ * This lock must be different than the initLock because the
+ * initLock is held during creation of syncronization objects.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Acquire the master mutex.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpMasterLock()
+{
+ if (!init) {
+ /*
+ * There is a fundamental race here that is solved by creating
+ * the first Tcl interpreter in a single threaded environment.
+ * Once the interpreter has been created, it is safe to create
+ * more threads that create interpreters in parallel.
+ */
+ init = 1;
+ InitializeCriticalSection(&initLock);
+ InitializeCriticalSection(&masterLock);
+ }
+ EnterCriticalSection(&masterLock);
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpMasterUnlock
+ *
+ * This procedure is used to release a lock that serializes creation
+ * and deletion of synchronization objects.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Release the master mutex.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpMasterUnlock()
+{
+ LeaveCriticalSection(&masterLock);
+}
+
+#ifdef TCL_THREADS
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpMutexInit --
+ * TclpMutexLock --
+ * TclpMutexUnlock --
+ *
+ * These procedures use an explicitly initialized mutex.
+ * These are used by memory allocators for their own mutex.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Initialize, Lock, and Unlock the mutex.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpMutexInit(mPtr)
+ TclpMutex *mPtr;
+{
+ InitializeCriticalSection((CRITICAL_SECTION *)mPtr);
+}
+void
+TclpMutexLock(mPtr)
+ TclpMutex *mPtr;
+{
+ EnterCriticalSection((CRITICAL_SECTION *)mPtr);
+}
+void
+TclpMutexUnlock(mPtr)
+ TclpMutex *mPtr;
+{
+ LeaveCriticalSection((CRITICAL_SECTION *)mPtr);
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_MutexLock --
+ *
+ * This procedure is invoked to lock a mutex. This is a self
+ * initializing mutex that is automatically finalized during
+ * Tcl_Finalization.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * May block the current thread. The mutex is aquired when
+ * this returns.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_MutexLock(mutexPtr)
+ Tcl_Mutex *mutexPtr; /* The lock */
+{
+ CRITICAL_SECTION *csPtr;
+ if (*mutexPtr == NULL) {
+ MASTER_LOCK;
+
+ /*
+ * Double inside master lock check to avoid a race.
+ */
+
+ if (*mutexPtr == NULL) {
+ csPtr = (CRITICAL_SECTION *)ckalloc(sizeof(CRITICAL_SECTION));
+ InitializeCriticalSection(csPtr);
+ *mutexPtr = (Tcl_Mutex)csPtr;
+ TclRememberMutex(mutexPtr);
+ }
+ MASTER_UNLOCK;
+ }
+ csPtr = *((CRITICAL_SECTION **)mutexPtr);
+ EnterCriticalSection(csPtr);
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_MutexUnlock --
+ *
+ * This procedure is invoked to unlock a mutex.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The mutex is released when this returns.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_MutexUnlock(mutexPtr)
+ Tcl_Mutex *mutexPtr; /* The lock */
+{
+ CRITICAL_SECTION *csPtr = *((CRITICAL_SECTION **)mutexPtr);
+ LeaveCriticalSection(csPtr);
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpFinalizeMutex --
+ *
+ * This procedure is invoked to clean up one mutex. This is only
+ * safe to call at the end of time.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The mutex list is deallocated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpFinalizeMutex(mutexPtr)
+ Tcl_Mutex *mutexPtr;
+{
+ CRITICAL_SECTION *csPtr = *(CRITICAL_SECTION **)mutexPtr;
+ if (csPtr != NULL) {
+ ckfree((char *)csPtr);
+ *mutexPtr = NULL;
+ }
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpThreadDataKeyInit --
+ *
+ * This procedure initializes a thread specific data block key.
+ * Each thread has table of pointers to thread specific data.
+ * all threads agree on which table entry is used by each module.
+ * this is remembered in a "data key", that is just an index into
+ * this table. To allow self initialization, the interface
+ * passes a pointer to this key and the first thread to use
+ * the key fills in the pointer to the key. The key should be
+ * a process-wide static.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Will allocate memory the first time this process calls for
+ * this key. In this case it modifies its argument
+ * to hold the pointer to information about the key.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpThreadDataKeyInit(keyPtr)
+ Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk,
+ * really (pthread_key_t **) */
+{
+ DWORD *indexPtr;
+
+ MASTER_LOCK;
+ if (*keyPtr == NULL) {
+ indexPtr = (DWORD *)ckalloc(sizeof(DWORD));
+ *indexPtr = TlsAlloc();
+ *keyPtr = (Tcl_ThreadDataKey)indexPtr;
+ TclRememberDataKey(keyPtr);
+ }
+ MASTER_UNLOCK;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpThreadDataKeyGet --
+ *
+ * This procedure returns a pointer to a block of thread local storage.
+ *
+ * Results:
+ * A thread-specific pointer to the data structure, or NULL
+ * if the memory has not been assigned to this key for this thread.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+VOID *
+TclpThreadDataKeyGet(keyPtr)
+ Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk,
+ * really (DWORD **) */
+{
+ DWORD *indexPtr = *(DWORD **)keyPtr;
+ if (indexPtr == NULL) {
+ return NULL;
+ } else {
+ return (VOID *) TlsGetValue(*indexPtr);
+ }
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpThreadDataKeySet --
+ *
+ * This procedure sets the pointer to a block of thread local storage.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Sets up the thread so future calls to TclpThreadDataKeyGet with
+ * this key will return the data pointer.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpThreadDataKeySet(keyPtr, data)
+ Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk,
+ * really (pthread_key_t **) */
+ VOID *data; /* Thread local storage */
+{
+ DWORD *indexPtr = *(DWORD **)keyPtr;
+ TlsSetValue(*indexPtr, (void *)data);
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpFinalizeThreadData --
+ *
+ * This procedure cleans up the thread-local storage. This is
+ * called once for each thread.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Frees up the memory.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpFinalizeThreadData(keyPtr)
+ Tcl_ThreadDataKey *keyPtr;
+{
+ VOID *result;
+ DWORD *indexPtr;
+
+ if (*keyPtr != NULL) {
+ indexPtr = *(DWORD **)keyPtr;
+ result = (VOID *)TlsGetValue(*indexPtr);
+ if (result != NULL) {
+ ckfree((char *)result);
+ TlsSetValue(*indexPtr, (void *)NULL);
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpFinalizeThreadDataKey --
+ *
+ * This procedure is invoked to clean up one key. This is a
+ * process-wide storage identifier. The thread finalization code
+ * cleans up the thread local storage itself.
+ *
+ * This assumes the master lock is held.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The key is deallocated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpFinalizeThreadDataKey(keyPtr)
+ Tcl_ThreadDataKey *keyPtr;
+{
+ DWORD *indexPtr;
+ if (*keyPtr != NULL) {
+ indexPtr = *(DWORD **)keyPtr;
+ TlsFree(*indexPtr);
+ ckfree((char *)indexPtr);
+ *keyPtr = NULL;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpConditionWait --
+ *
+ * This procedure is invoked to wait on a condition variable.
+ * The mutex is automically released as part of the wait, and
+ * automatically grabbed when the condition is signaled.
+ *
+ * The mutex must be held when this procedure is called.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * May block the current thread. The mutex is aquired when
+ * this returns. Will allocate memory for a HANDLE
+ * and initialize this the first time this Tcl_Condition is used.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpConditionWait(condPtr, mutexPtr, timePtr)
+ Tcl_Condition *condPtr; /* Really (pthread_cond_t **) */
+ Tcl_Mutex *mutexPtr; /* Really (pthread_mutex_t **) */
+ Tcl_Time *timePtr; /* Timeout on waiting period */
+{
+ HANDLE *eventPtr;
+ CRITICAL_SECTION *csPtr;
+ DWORD wtime;
+
+ if (*condPtr == NULL) {
+ MASTER_LOCK;
+
+ /*
+ * Double check inside mutex to avoid race,
+ * then initialize condition variable if necessary.
+ */
+
+ if (*condPtr == NULL) {
+ eventPtr = (HANDLE *)ckalloc(sizeof(HANDLE));
+ *eventPtr = CreateEvent(NULL, TRUE /* manual reset */,
+ FALSE /* non signaled */, NULL);
+ *condPtr = (Tcl_Condition)eventPtr;
+ TclRememberCondition(condPtr);
+ }
+ MASTER_UNLOCK;
+ }
+ csPtr = *((CRITICAL_SECTION **)mutexPtr);
+ eventPtr = *((HANDLE **)condPtr);
+ if (timePtr == NULL) {
+ wtime = INFINITE;
+ } else {
+ wtime = timePtr->sec * 1000 + timePtr->usec / 1000;
+ }
+
+ /*
+ * Clear the event it case there are old notifies.
+ */
+
+ ResetEvent(*eventPtr);
+ LeaveCriticalSection(csPtr);
+
+ /*
+ * This point is a race with a notification, but this is handled
+ * by the "stickiness" of the event. If a notification occurs here,
+ * then WaitForSingleObject will not block.
+ */
+
+ WaitForSingleObject(*eventPtr, wtime);
+
+ /*
+ * This point is a race with other waiters. Someone else can grab
+ * the mutex first. This is why our caller must check its invariant
+ * and perhaps wait again.
+ */
+
+ EnterCriticalSection(csPtr);
+
+ /*
+ * "Consume" the event - hmm - this may not be necessary because it
+ * will be done before the next wait.
+ */
+
+ ResetEvent(*eventPtr);
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpConditionNotify --
+ *
+ * This procedure is invoked to signal a condition variable.
+ *
+ * The mutex must be held during this call to avoid races,
+ * but this interface does not enforce that.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * May unblock another thread.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpConditionNotify(condPtr)
+ Tcl_Condition *condPtr;
+{
+ HANDLE *eventPtr;
+ if (condPtr != NULL) {
+ eventPtr = *((HANDLE **)condPtr);
+
+ /*
+ * The PulseEvent may not be necessary, but it's documentation says
+ * it releases all waiting processes, which is what we want. However,
+ * it also clears the signal, which is not good because of the race
+ * in ConditionWait. The SetEvent makes sure the signal remains
+ * even if there are no waiters, but we are not sure that it really
+ * marks all waiters as runnable. So we do both.
+ */
+
+ PulseEvent(*eventPtr);
+ SetEvent(*eventPtr);
+ } else {
+ /*
+ * Noone has used the condition variable, so there are no waiters.
+ */
+ }
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpFinalizeCondition --
+ *
+ * This procedure is invoked to clean up a condition variable.
+ * This is only safe to call at the end of time.
+ *
+ * This assumes the Master Lock is held.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The condition variable is deallocated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpFinalizeCondition(condPtr)
+ Tcl_Condition *condPtr;
+{
+ HANDLE *eventPtr = *(HANDLE **)condPtr;
+ if (eventPtr != NULL) {
+ CloseHandle(*eventPtr);
+ ckfree((char *)eventPtr);
+ *condPtr = NULL;
+ }
+}
+#endif TCL_THREADS
+
+
diff --git a/win/tclWinThrd.h b/win/tclWinThrd.h
new file mode 100644
index 0000000..2572d1b
--- /dev/null
+++ b/win/tclWinThrd.h
@@ -0,0 +1,21 @@
+/*
+ * tclWinThrd.h --
+ *
+ * This header file defines things for thread support.
+ *
+ * Copyright (c) 1998 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclWinThrd.h 1.2 98/01/27 11:48:05
+ */
+
+#ifndef _TCLWINTHRD
+#define _TCLWINTHRD
+
+#ifdef TCL_THREADS
+
+#endif /* TCL_THREADS */
+
+#endif /* _TCLWINTHRD */
diff --git a/win/tclWinTime.c b/win/tclWinTime.c
index b59f68d..8570e65 100644
--- a/win/tclWinTime.c
+++ b/win/tclWinTime.c
@@ -4,16 +4,15 @@
* Contains Windows specific versions of Tcl functions that
* obtain time values from the operating system.
*
- * Copyright 1995 by Sun Microsystems, Inc.
+ * Copyright 1995-1998 by Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclWinTime.c 1.6 97/04/14 17:25:56
+ * SCCS: @(#) tclWinTime.c 1.11 98/02/19 14:30:36
*/
-#include "tclInt.h"
-#include "tclPort.h"
+#include "tclWinInt.h"
#define SECSPERDAY (60L * 60L * 24L)
#define SECSPERYEAR (SECSPERDAY * 365L)
@@ -32,6 +31,12 @@ static int leapDays[] = {
-1, 30, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365
};
+typedef struct ThreadSpecificData {
+ char tzName[64]; /* Time zone name */
+ struct tm tm; /* time information */
+} ThreadSpecificData;
+static Tcl_ThreadDataKey dataKey;
+
/*
* Declarations for functions defined later in this file.
*/
@@ -162,14 +167,70 @@ TclpGetTime(timePtr)
*/
char *
-TclpGetTZName()
+TclpGetTZName(int dst)
{
- tzset();
- if (_daylight && _tzname[1] != NULL) {
- return _tzname[1];
- } else {
- return _tzname[0];
+ int len;
+ char *zone, *p;
+ TIME_ZONE_INFORMATION tz;
+ Tcl_Encoding encoding;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ char *name = tsdPtr->tzName;
+
+ /*
+ * tzset() under Borland doesn't seem to set up tzname[] at all.
+ * tzset() under MSVC has the following weird observed behavior:
+ * First time we call "clock format [clock seconds] -format %Z -gmt 1"
+ * we get "GMT", but on all subsequent calls we get the current time
+ * zone string, even though env(TZ) is GMT and the variable _timezone
+ * is 0.
+ */
+
+ name[0] = '\0';
+
+ zone = getenv("TZ");
+ if (zone != NULL) {
+ /*
+ * TZ is of form "NST-4:30NDT", where "NST" would be the
+ * name of the standard time zone for this area, "-4:30" is
+ * the offset from GMT in hours, and "NDT is the name of
+ * the daylight savings time zone in this area. The offset
+ * and DST strings are optional.
+ */
+
+ len = strlen(zone);
+ if (len > 3) {
+ len = 3;
+ }
+ if (dst != 0) {
+ /*
+ * Skip the offset string and get the DST string.
+ */
+
+ p = zone + len;
+ p += strspn(p, "+-:0123456789");
+ if (*p != '\0') {
+ zone = p;
+ len = strlen(zone);
+ if (len > 3) {
+ len = 3;
+ }
+ }
+ }
+ Tcl_ExternalToUtf(NULL, NULL, zone, len, 0, NULL, name,
+ sizeof(tsdPtr->tzName), NULL, NULL, NULL);
+ }
+ if ((name[0] == '\0')
+ && (GetTimeZoneInformation(&tz) != TIME_ZONE_ID_UNKNOWN)) {
+ encoding = Tcl_GetEncoding(NULL, "unicode");
+ Tcl_ExternalToUtf(NULL, encoding,
+ (char *) ((dst) ? tz.DaylightName : tz.StandardName), -1,
+ 0, NULL, name, sizeof(tsdPtr->tzName), NULL, NULL, NULL);
+ Tcl_FreeEncoding(encoding);
+ }
+ if (name[0] == '\0') {
+ return "%Z";
}
+ return name;
}
/*
@@ -272,7 +333,7 @@ TclpGetDate(tp, useGMT)
* the epoch (midnight Jan 1 1970).
*
* Results:
- * Returns a statically allocated struct tm.
+ * Returns a (per thread) statically allocated struct tm.
*
* Side effects:
* Updates the values of the static struct tm.
@@ -284,10 +345,13 @@ static struct tm *
ComputeGMT(tp)
const time_t *tp;
{
- static struct tm tm; /* This should be allocated per thread.*/
+ struct tm *tmPtr;
long tmp, rem;
int isLeap;
int *days;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ tmPtr = &tsdPtr->tm;
/*
* Compute the 4 year span containing the specified time.
@@ -327,47 +391,47 @@ ComputeGMT(tp)
}
}
}
- tm.tm_year = tmp;
+ tmPtr->tm_year = tmp;
/*
* Compute the day of year and leave the seconds in the current day in
* the remainder.
*/
- tm.tm_yday = rem / SECSPERDAY;
+ tmPtr->tm_yday = rem / SECSPERDAY;
rem %= SECSPERDAY;
/*
* Compute the time of day.
*/
- tm.tm_hour = rem / 3600;
+ tmPtr->tm_hour = rem / 3600;
rem %= 3600;
- tm.tm_min = rem / 60;
- tm.tm_sec = rem % 60;
+ tmPtr->tm_min = rem / 60;
+ tmPtr->tm_sec = rem % 60;
/*
* Compute the month and day of month.
*/
days = (isLeap) ? leapDays : normalDays;
- for (tmp = 1; days[tmp] < tm.tm_yday; tmp++) {
+ for (tmp = 1; days[tmp] < tmPtr->tm_yday; tmp++) {
}
- tm.tm_mon = --tmp;
- tm.tm_mday = tm.tm_yday - days[tmp];
+ tmPtr->tm_mon = --tmp;
+ tmPtr->tm_mday = tmPtr->tm_yday - days[tmp];
/*
* Compute day of week. Epoch started on a Thursday.
*/
- tm.tm_wday = (*tp / SECSPERDAY) + 4;
+ tmPtr->tm_wday = (*tp / SECSPERDAY) + 4;
if ((*tp % SECSPERDAY) < 0) {
- tm.tm_wday--;
+ tmPtr->tm_wday--;
}
- tm.tm_wday %= 7;
- if (tm.tm_wday < 0) {
- tm.tm_wday += 7;
+ tmPtr->tm_wday %= 7;
+ if (tmPtr->tm_wday < 0) {
+ tmPtr->tm_wday += 7;
}
- return &tm;
+ return tmPtr;
}
diff --git a/win/tclsh.rc b/win/tclsh.rc
index e48c157..b340a1a 100644
--- a/win/tclsh.rc
+++ b/win/tclsh.rc
@@ -1,4 +1,4 @@
-// SCCS: @(#) tclsh.rc 1.15 96/09/18 18:19:38
+// SCCS: @(#) tclsh.rc 1.18 98/01/20 19:38:48
//
// Version
//
@@ -6,13 +6,15 @@
#define RESOURCE_INCLUDED
#include <tcl.h>
+LANGUAGE 0x9, 0x1 /* LANG_ENGLISH, SUBLANG_DEFAULT */
+
VS_VERSION_INFO VERSIONINFO
FILEVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL
PRODUCTVERSION TCL_MAJOR_VERSION,TCL_MINOR_VERSION,TCL_RELEASE_LEVEL,TCL_RELEASE_SERIAL
FILEFLAGSMASK 0x3fL
FILEFLAGS 0x0L
- FILEOS 0x4L
- FILETYPE 0x1L
+ FILEOS 0x4 /* VOS__WINDOWS32 */
+ FILETYPE 0x2 /* VFT_DLL */
FILESUBTYPE 0x0L
BEGIN
BLOCK "StringFileInfo"
@@ -23,7 +25,7 @@ BEGIN
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 "LegalCopyright", "Copyright (c) 1995-1996\0"
VALUE "ProductName", "Tcl " TCL_VERSION " for Windows\0"
VALUE "ProductVersion", TCL_PATCH_LEVEL
END
generated by cgit v0.12 at 2024-10-28 03:52:44 (GMT)