diff options
author | dgp <dgp@users.sourceforge.net> | 2012-08-08 20:30:37 (GMT) |
---|---|---|
committer | dgp <dgp@users.sourceforge.net> | 2012-08-08 20:30:37 (GMT) |
commit | 23754cbbc81ac0eda71610fe3737a8bc8ae31c65 (patch) | |
tree | a6fadf3d6bc55a704065f4543ea894d5ebddfe46 /win | |
parent | ff0e2463cb108f9b0481ac516251142506818114 (diff) | |
parent | 7ce9d6f8fc9b0c2b4fd1a18a85c54bb37387dda0 (diff) | |
download | tcl-23754cbbc81ac0eda71610fe3737a8bc8ae31c65.zip tcl-23754cbbc81ac0eda71610fe3737a8bc8ae31c65.tar.gz tcl-23754cbbc81ac0eda71610fe3737a8bc8ae31c65.tar.bz2 |
merge trunk
Diffstat (limited to 'win')
-rw-r--r-- | win/Makefile.in | 58 | ||||
-rw-r--r-- | win/README | 26 | ||||
-rw-r--r-- | win/coffbase.txt | 2 | ||||
-rwxr-xr-x | win/configure | 14 | ||||
-rw-r--r-- | win/configure.in | 2 | ||||
-rw-r--r-- | win/makefile.vc | 95 | ||||
-rw-r--r-- | win/nmakehlp.c | 71 | ||||
-rw-r--r-- | win/rules.vc | 10 | ||||
-rw-r--r-- | win/tcl.m4 | 12 | ||||
-rw-r--r-- | win/tclWinChan.c | 16 | ||||
-rw-r--r-- | win/tclWinDde.c | 92 | ||||
-rw-r--r-- | win/tclWinFCmd.c | 16 | ||||
-rw-r--r-- | win/tclWinFile.c | 12 | ||||
-rw-r--r-- | win/tclWinLoad.c | 34 | ||||
-rw-r--r-- | win/tclWinPipe.c | 84 | ||||
-rw-r--r-- | win/tclWinPort.h | 4 | ||||
-rw-r--r-- | win/tclWinReg.c | 88 | ||||
-rw-r--r-- | win/tclWinSerial.c | 143 | ||||
-rw-r--r-- | win/tclWinSock.c | 42 |
19 files changed, 462 insertions, 359 deletions
diff --git a/win/Makefile.in b/win/Makefile.in index d5a335d..84dcaf7 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -137,10 +137,9 @@ TEST_LIB_FILE = @LIBPREFIX@tcltest$(VER)${LIBSUFFIX} ZLIB_DLL_FILE = zlib1.dll SHARED_LIBRARIES = $(TCL_DLL_FILE) @ZLIB_DLL_FILE@ -STATIC_LIBRARIES = $(TCL_LIB_FILE) $(REG_LIB_FILE) $(DDE_LIB_FILE) +STATIC_LIBRARIES = $(TCL_LIB_FILE) TCLSH = tclsh$(VER)${EXESUFFIX} -TCLTEST = tcltest${EXEEXT} CAT32 = cat32$(EXEEXT) MAN2TCL = man2tcl$(EXEEXT) @@ -403,7 +402,7 @@ TCL_DOCS = "$(ROOT_DIR_NATIVE)"/doc/*.[13n] all: binaries libraries doc packages -tcltest: $(TCLTEST) +tcltest: $(TCLSH) $(TEST_DLL_FILE) binaries: $(TCL_STUB_LIB_FILE) @LIBRARIES@ $(DDE_DLL_FILE) $(REG_DLL_FILE) $(TCLSH) @@ -416,11 +415,6 @@ $(TCLSH): $(TCLSH_OBJS) @LIBRARIES@ $(TCL_STUB_LIB_FILE) tclsh.$(RES) tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE) @VC_MANIFEST_EMBED_EXE@ -$(TCLTEST): testMain.$(OBJEXT) ${TEST_DLL_FILE} @LIBRARIES@ $(TCL_STUB_LIB_FILE) $(CAT32) tclsh.$(RES) - $(CC) $(CFLAGS) testMain.$(OBJEXT) ${TEST_LIB_FILE} $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \ - tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE) - @VC_MANIFEST_EMBED_EXE@ - cat32.$(OBJEXT): cat.c $(CC) -c $(CC_SWITCHES) @DEPARG@ $(CC_OBJNAME) @@ -440,9 +434,9 @@ ${TCL_DLL_FILE}: ${TCL_OBJS} tcl.$(RES) @ZLIB_DLL_FILE@ @MAKE_DLL@ ${TCL_OBJS} tcl.$(RES) $(SHLIB_LD_LIBS) @VC_MANIFEST_EMBED_DLL@ -${TCL_LIB_FILE}: ${TCL_OBJS} +${TCL_LIB_FILE}: ${TCL_OBJS} ${DDE_OBJS} ${REG_OBJS} @$(RM) ${TCL_LIB_FILE} - @MAKE_LIB@ ${TCL_OBJS} + @MAKE_LIB@ ${TCL_OBJS} ${DDE_OBJS} ${REG_OBJS} @POST_MAKE_LIB@ # assume GNU make @@ -451,31 +445,11 @@ ${TCL_LIB_FILE}: ${TCL_OBJS} # targets have to depend on tcl<x>.lib, this ensures that linking of tcl<x>.dll # does not execute concurrently with the renaming and recompiling of tcl<x>.lib -${DDE_DLL_FILE}: ${DDE_OBJS} ${DDE_LIB_FILE} ${TCL_STUB_LIB_FILE} - @-$(RM) ${DDE_DLL_FILE} ${DDE_LIB_FILE}.sav - @-$(COPY) ${DDE_LIB_FILE} ${DDE_LIB_FILE}.sav +${DDE_DLL_FILE}: ${DDE_OBJS} ${TCL_STUB_LIB_FILE} @MAKE_DLL@ ${DDE_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) - @-$(RM) ${DDE_LIB_FILE} - @-$(COPY) ${DDE_LIB_FILE}.sav ${DDE_LIB_FILE} - @-$(RM) ${DDE_LIB_FILE}.sav -${DDE_LIB_FILE}: ${DDE_OBJS} - @$(RM) ${DDE_LIB_FILE} - @MAKE_LIB@ ${DDE_OBJS} - @POST_MAKE_LIB@ - -${REG_DLL_FILE}: ${REG_OBJS} ${REG_LIB_FILE} ${TCL_STUB_LIB_FILE} - @-$(RM) ${REG_DLL_FILE} ${REG_LIB_FILE}.sav - @-$(COPY) ${REG_LIB_FILE} ${REG_LIB_FILE}.sav +${REG_DLL_FILE}: ${REG_OBJS} ${TCL_STUB_LIB_FILE} @MAKE_DLL@ ${REG_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS) - @-$(RM) ${REG_LIB_FILE} - @-$(COPY) ${REG_LIB_FILE}.sav ${REG_LIB_FILE} - @-$(RM) ${REG_LIB_FILE}.sav - -${REG_LIB_FILE}: ${REG_OBJS} - @$(RM) ${REG_LIB_FILE} - @MAKE_LIB@ ${REG_OBJS} - @POST_MAKE_LIB@ ${TEST_DLL_FILE}: ${TCLTEST_OBJS} ${TCL_STUB_LIB_FILE} @$(RM) ${TEST_DLL_FILE} ${TEST_LIB_FILE} @@ -719,17 +693,19 @@ install-private-headers: libraries test: test-tcl test-packages -test-tcl: binaries $(TCLTEST) +test-tcl: binaries $(TCLSH) $(CAT32) $(TEST_DLL_FILE) TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ - ./$(TCLTEST) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \ - -load "set ::ddelib [file normalize ${DDE_DLL_FILE}]; \ - set ::reglib [file normalize ${REG_DLL_FILE}]" | ./$(CAT32) + ./$(TCLSH) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \ + -load "package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest]; \ + package ifneeded dde 1.4.0b1 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ + package ifneeded registry 1.3.0 [list load [file normalize ${REG_DLL_FILE}] registry]" | ./$(CAT32) -# Useful target to launch a built tcltest with the proper path,... -runtest: binaries $(TCLTEST) +# Useful target to launch a built tclsh with the proper path,... +runtest: binaries $(TCLSH) $(TEST_DLL_FILE) @TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ - ./$(TCLTEST) $(TESTFLAGS) -load "set ::ddelib [file normalize ${DDE_DLL_FILE}]; \ - set ::reglib [file normalize ${REG_DLL_FILE}]" $(SCRIPT) + ./$(TCLSH) $(TESTFLAGS) -load "package ifneeded Tcltest ${VERSION}@TCL_PATCH_LEVEL@ [list load [file normalize ${TEST_DLL_FILE}] Tcltest]; \ + package ifneeded dde 1.4.0b1 [list load [file normalize ${DDE_DLL_FILE}] dde]; \ + package ifneeded registry 1.3.0 [list load [file normalize ${REG_DLL_FILE}] registry]" $(SCRIPT) # This target can be used to run tclsh from the build directory via # `make shell SCRIPT=foo.tcl` @@ -753,7 +729,7 @@ cleanhelp: clean: cleanhelp clean-packages $(RM) *.lib *.a *.exp *.dll *.$(RES) *.${OBJEXT} *~ \#* TAGS a.out - $(RM) $(TCLSH) $(TCLTEST) $(CAT32) + $(RM) $(TCLSH) $(CAT32) $(RM) *.pch *.ilk *.pdb distclean: distclean-packages clean @@ -24,28 +24,28 @@ In order to compile Tcl for Windows, you need the following: or - Linux + MinGW-w64 (any distribution e.g. Ubuntu) - (for either 32-bit or 64-bit executables) + Linux + MinGW-w64 [http://mingw-w64.sourceforge.net/] + (win32 or win64) or Cygwin + MinGW-w64 [http://cygwin.com/install.html] - (for either 32-bit or 64-bit executables) + (win32 or win64) or Darwin + MinGW-w64 [http://mingw-w64.sourceforge.net/] - (for either 32-bit or 64-bit executables) + (win32 or win64) or Msys + MinGW-w64 [http://mingw-w64.sourceforge.net/] - (for either 32-bit or 64-bit executables) + (win32 or win64) or - Msys + Mingw [http://www.mingw.org/download.shtml] - (32-bit executables only) + Msys + MinGW [http://www.mingw.org/download.shtml] + (win32 only) In practice, this release is built with Visual C++ 6.0 and the TEA @@ -67,20 +67,20 @@ configure/build process works just like the UNIX one, so you will want to refer to ../unix/README for available configure options. If you want 64-bit executables (x86_64), you need to configure using -the --enable-64bit option. Then make sure that the x86_64-w64-mingw32 +the --enable-64bit option. Make sure that the x86_64-w64-mingw32 compiler is present. For Cygwin this compiler can be found in the "mingw64-x86_64-gcc-core" package, which can be installed through the normal Cygwin install process. If you only want 32-bit executables, -the "mingw64-i686-gcc-core" package is what you need. If your Linux -distribution does not have a MinGW-w64 package, you can download one -from [https://sourceforge.net/projects/mingw-w64/files/] +the "mingw64-i686-gcc-core" package is what you need. For Linux, Darwin +and Msys, you can download a suitable win32 or win64 compiler from +[https://sourceforge.net/projects/mingw-w64/files/] Use the Makefile "install" target to install Tcl. It will install it according to the prefix options you provided in the correct directory structure. -Note that in order to run tclsh86.exe, you must ensure that tcl86.dll is on -your path, in the system directory, or in the directory containing +Note that in order to run tclsh85.exe, you must ensure that tcl85.dll is +on your path, in the system directory, or in the directory containing tclsh86.exe. Note: Tcl no longer provides support for Win32s. diff --git a/win/coffbase.txt b/win/coffbase.txt index 7d19420..bdf5506 100644 --- a/win/coffbase.txt +++ b/win/coffbase.txt @@ -24,6 +24,7 @@ blt 0x10680000 0x00080000 iocpsock 0x10700000 0x00080000 tls 0x10780000 0x00100000 winico 0x10880000 0x00010000 +sample 0x108B0000 0x00010000 tile 0x10900000 0x00080000 memchan 0x109D0000 0x00010000 tdom 0x109E0000 0x00080000 @@ -32,6 +33,7 @@ tkvideo 0x10B00000 0x00010000 tclsdl 0x10B20000 0x00080000 vqtcl 0x10C00000 0x00010000 tdbc 0x10C40000 0x00010000 +thread 0x10C80000 0x00020000 ; ; insert new packages here ; diff --git a/win/configure b/win/configure index 04a5e90..757a6e8 100755 --- a/win/configure +++ b/win/configure @@ -840,18 +840,18 @@ if test -n "$ac_init_help"; then Optional Features: --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) --enable-FEATURE[=ARG] include FEATURE [ARG=yes] - --enable-threads build with threads - --enable-shared build and link with shared libraries --enable-shared + --enable-threads build with threads (default: on) + --enable-shared build and link with shared libraries (default: on) --enable-64bit enable 64bit support (where applicable) --enable-wince enable Win/CE support (where applicable) - --enable-symbols build with debugging symbols --disable-symbols + --enable-symbols build with debugging symbols (default: off) --enable-embedded-manifest embed manifest if possible (default: yes) Optional Packages: --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) - --with-encoding encoding for configuration values + --with-encoding encoding for configuration values --with-celib=DIR use Windows/CE support library from DIR Some influential environment variables: @@ -3068,8 +3068,8 @@ else fi; if test "$tcl_ok" = "yes"; then - echo "$as_me:$LINENO: result: yes" >&5 -echo "${ECHO_T}yes" >&6 + echo "$as_me:$LINENO: result: yes (default)" >&5 +echo "${ECHO_T}yes (default)" >&6 TCL_THREADS=1 cat >>confdefs.h <<\_ACEOF #define TCL_THREADS 1 @@ -3598,8 +3598,8 @@ echo $ECHO_N "checking compiler flags... $ECHO_C" >&6 MAKE_EXE="\${CC} -o \$@" LIBPREFIX="lib" - extra_ldflags="$extra_ldflags -pipe" extra_cflags="$extra_cflags -pipe" + extra_ldflags="$extra_ldflags -pipe" if test "${SHARED_BUILD}" = "0" ; then # static diff --git a/win/configure.in b/win/configure.in index ae91a0a..950fca1 100644 --- a/win/configure.in +++ b/win/configure.in @@ -219,7 +219,7 @@ if test "$tcl_cv_intrinsics" = "yes"; then [Defined when the compilers supports intrinsics]) fi -# See if the <wspiapi.h> header file is present +# See if the <wspiapi.h> header file is present AC_CACHE_CHECK(for wspiapi.h, tcl_cv_wspiapi_h, diff --git a/win/makefile.vc b/win/makefile.vc index 96ae7f6..ba5b710 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -13,10 +13,9 @@ # Copyright (c) 2003-2008 Pat Thoyts. #------------------------------------------------------------------------------ -# Check to see we are configured to build with MSVC (MSDEVDIR or MSVCDIR) -# or with the MS Platform SDK (MSSDK). Visual Studio .NET 2003 and 2005 define -# VCINSTALLDIR instead. -!if !defined(MSDEVDIR) && !defined(MSVCDIR) && !defined(MSSDK) && !defined(VCINSTALLDIR) +# Check to see we are configured to build with MSVC (MSDEVDIR, MSVCDIR or +# VCINSTALLDIR) or with the MS Platform SDK (MSSDK or WindowsSDKDir) +!if !defined(MSDEVDIR) && !defined(MSVCDIR) && !defined(VCINSTALLDIR) && !defined(MSSDK) && !defined(WINDOWSSDKDIR) MSG = ^ You need to run vcvars32.bat from Developer Studio or setenv.bat from the^ Platform SDK first to setup the environment. Jump to this line to read^ @@ -72,57 +71,62 @@ the build instructions. # Sets where to install Tcl from the built binaries. # C:\Progra~1\Tcl is assumed when not specified. # -# OPTS=static,msvcrt,staticpkg,nothreads,symbols,profile,loimpact,unchecked,pdbs,none +# OPTS=loimpact,msvcrt,nothreads,pdbs,profile,static,staticpkg,symbols,thrdalloc,tclalloc,unchecked,none # Sets special options for the core. The default is for none. # Any combination of the above may be used (comma separated). # 'none' will over-ride everything to nothing. # -# static = Builds a static library of the core instead of a -# dll. The shell will be static (and large), as well. -# msvcrt = Affects the static option only to switch it from +# loimpact = Adds a flag for how NT treats the heap to keep memory +# in use, low. This is said to impact alloc performance. +# msvcrt = Affects the static option only to switch it from # using libcmt(d) as the C runtime [by default] to # msvcrt(d). This is useful for static embedding # support. +# nothreads= Turns off full multithreading support. +# pdbs = Build detached symbols for release builds. +# profile = Adds profiling hooks. Map file is assumed. +# static = Builds a static library of the core instead of a +# dll. The static library will contain the dde and reg +# extensions. External applications who want to use +# this, need to link with the stub library as well as +# the static Tcl library.The shell will be static (and +# large), as well. # staticpkg = Affects the static option only to switch # tclshXX.exe to have the dde and reg extension linked # inside it. -# nothreads = Turns off full multithreading support. +# symbols = Debug build. Links to the debug C runtime, disables +# optimizations and creates pdb symbols files. # thrdalloc = Use the thread allocator (shared global free pool) # This is the default on threaded builds. # tclalloc = Use the old non-thread allocator -# symbols = Debug build. Links to the debug C runtime, disables -# optimizations and creates pdb symbols files. -# pdbs = Build detached symbols for release builds. -# profile = Adds profiling hooks. Map file is assumed. -# loimpact = Adds a flag for how NT treats the heap to keep memory -# in use, low. This is said to impact alloc performance. -# unchecked = Allows a symbols build to not use the debug +# unchecked= Allows a symbols build to not use the debug # enabled runtime (msvcrt.dll not msvcrtd.dll # or libcmt.lib not libcmtd.lib). # -# STATS=memdbg,compdbg,none +# STATS=compdbg,memdbg,none # Sets optional memory and bytecode compiler debugging code added # to the core. The default is for none. Any combination of the # above may be used (comma separated). 'none' will over-ride # everything to nothing. # -# memdbg = Enables the debugging memory allocator. # compdbg = Enables byte compilation logging. +# memdbg = Enables the debugging memory allocator. # -# CHECKS=nodep,fullwarn,64bit,none +# CHECKS=64bit,fullwarn,nodep,none # Sets special macros for checking compatability. # -# nodep = Turns off compatability macros to ensure the core -# isn't being built with deprecated functions. +# 64bit = Enable 64bit portability warnings (if available) # fullwarn = Builds with full compiler and link warnings enabled. # Very verbose. -# 64bit = Enable 64bit portability warnings (if available) +# nodep = Turns off compatability macros to ensure the core +# isn't being built with deprecated functions. # -# MACHINE=(IX86|IA64|AMD64|ALPHA) +# MACHINE=(ALPHA|AMD64|IA64|IX86) # Set the machine type used for the compiler, linker, and # resource compiler. This hook is needed to tell the tools # when alternate platforms are requested. IX86 is the default -# when not specified. +# when not specified. If the CPU environment variable has been +# set (ie: recent Platform SDK) then MACHINE is set from CPU. # # TMP_DIR=<path> # OUT_DIR=<path> @@ -179,7 +183,7 @@ Please `cd` to its location first. !error $(MSG) !endif -PROJECT = tcl +PROJECT = tcl !include "rules.vc" STUBPREFIX = $(PROJECT)stub @@ -232,10 +236,12 @@ INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\include TCLSHOBJS = \ $(TMP_DIR)\tclAppInit.obj \ +!if !$(STATIC_BUILD) !if $(TCL_USE_STATIC_PACKAGES) $(TMP_DIR)\tclWinReg.obj \ $(TMP_DIR)\tclWinDde.obj \ !endif +!endif $(TMP_DIR)\tclsh.res TCLTESTOBJS = \ @@ -244,10 +250,12 @@ TCLTESTOBJS = \ $(TMP_DIR)\tclTestProcBodyObj.obj \ $(TMP_DIR)\tclThreadTest.obj \ $(TMP_DIR)\tclWinTest.obj \ +!if !$(STATIC_BUILD) !if $(TCL_USE_STATIC_PACKAGES) $(TMP_DIR)\tclWinReg.obj \ $(TMP_DIR)\tclWinDde.obj \ !endif +!endif $(TMP_DIR)\testMain.obj COREOBJS = \ @@ -429,11 +437,13 @@ PLATFORMOBJS = \ $(TMP_DIR)\tclWinSock.obj \ $(TMP_DIR)\tclWinThrd.obj \ $(TMP_DIR)\tclWinTime.obj \ -!if !$(STATIC_BUILD) +!if $(STATIC_BUILD) + $(TMP_DIR)\tclWinReg.obj \ + $(TMP_DIR)\tclWinDde.obj \ +!else $(TMP_DIR)\tcl.res !endif - TCLOBJS = $(COREOBJS) $(ZLIBOBJS) $(TOMMATHOBJS) $(PLATFORMOBJS) TCLSTUBOBJS = \ @@ -565,27 +575,27 @@ install: install-binaries install-libraries install-docs install-pkgs test: test-core test-pkgs test-core: setup $(TCLTEST) dlls $(CAT32) - set TCL_LIBRARY=$(ROOT:\=/)/../library + set TCL_LIBRARY=$(ROOT:\=/)/library !if "$(OS)" == "Windows_NT" || "$(MSVCDIR)" == "IDE" - $(DEBUGGER) $(TCLTEST) "$(ROOT)/tests/all.tcl" $(TESTFLAGS) -loadfile << - set ::ddelib [file normalize $(TCLDDELIB:\=/)] - set ::reglib [file normalize $(TCLREGLIB:\=/)] + $(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << + package ifneeded dde 1.4.0b1 [list load "$(TCLDDELIB:\=/)" dde] + package ifneeded registry 1.3.0 [list load "$(TCLREGLIB:\=/)" registry] << !else @echo Please wait while the tests are collected... - $(TCLTEST) "$(ROOT)/tests/all.tcl" $(TESTFLAGS) -loadfile << > tests.log - set ::ddelib [file normalize $(TCLDDELIB:\=/)] - set ::reglib [file normalize $(TCLREGLIB:\=/)] + $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << > tests.log + package ifneeded dde 1.4.0b1 "$(TCLDDELIB:\=/)" dde] + package ifneeded registry 1.3.0 "$(TCLREGLIB:\=/)" registry] << type tests.log | more !endif runtest: setup $(TCLTEST) dlls $(CAT32) - set TCL_LIBRARY=$(ROOT)/library + set TCL_LIBRARY=$(ROOT:\=/)/library $(DEBUGGER) $(TCLTEST) $(SCRIPT) runshell: setup $(TCLSH) dlls - set TCL_LIBRARY=$(ROOT)/library + set TCL_LIBRARY=$(ROOT:\=/)/library $(DEBUGGER) $(TCLSH) $(SCRIPT) setup: @@ -820,7 +830,6 @@ install-docs: @$(CPY) "$(HELPCNT)" "$(DOC_INSTALL_DIR)\" !endif -#" #--------------------------------------------------------------------- # Build tclConfig.sh for the TEA build system. #--------------------------------------------------------------------- @@ -1159,15 +1168,15 @@ install-libraries: tclConfig install-msgs install-tzdata install-tzdata: @echo Installing time zone data - @set TCL_LIBRARY=$(ROOT)/library - @$(TCLSH_NATIVE) "$(ROOT)/tools/installData.tcl" \ - "$(ROOT)/library/tzdata" "$(SCRIPT_INSTALL_DIR)/tzdata" + @set TCL_LIBRARY=$(ROOT:\=/)/library + @$(TCLSH_NATIVE) "$(ROOT:\=/)/tools/installData.tcl" \ + "$(ROOT:\=/)/library/tzdata" "$(SCRIPT_INSTALL_DIR)/tzdata" install-msgs: @echo Installing message catalogs - @set TCL_LIBRARY=$(ROOT)/library - @$(TCLSH_NATIVE) "$(ROOT)/tools/installData.tcl" \ - "$(ROOT)/library/msgs" "$(SCRIPT_INSTALL_DIR)/msgs" + @set TCL_LIBRARY=$(ROOT:\=/)/library + @$(TCLSH_NATIVE) "$(ROOT:\=/)/tools/installData.tcl" \ + "$(ROOT:\=/)/library/msgs" "$(SCRIPT_INSTALL_DIR)/msgs" #--------------------------------------------------------------------- # Clean up diff --git a/win/nmakehlp.c b/win/nmakehlp.c index b5e0788..2868857 100644 --- a/win/nmakehlp.c +++ b/win/nmakehlp.c @@ -14,8 +14,13 @@ #define _CRT_SECURE_NO_DEPRECATE #include <windows.h> +#define NO_SHLWAPI_GDI +#define NO_SHLWAPI_STREAM +#define NO_SHLWAPI_REG +#include <shlwapi.h> #pragma comment (lib, "user32.lib") #pragma comment (lib, "kernel32.lib") +#pragma comment (lib, "shlwapi.lib") #include <stdio.h> #include <math.h> @@ -37,12 +42,13 @@ /* protos */ -int CheckForCompilerFeature(const char *option); -int CheckForLinkerFeature(const char *option); -int IsIn(const char *string, const char *substring); -int SubstituteFile(const char *substs, const char *filename); -const char * GetVersionFromFile(const char *filename, const char *match); -DWORD WINAPI ReadFromPipe(LPVOID args); +static int CheckForCompilerFeature(const char *option); +static int CheckForLinkerFeature(const char *option); +static int IsIn(const char *string, const char *substring); +static int SubstituteFile(const char *substs, const char *filename); +static int QualifyPath(const char *path); +static const char *GetVersionFromFile(const char *filename, const char *match); +static DWORD WINAPI ReadFromPipe(LPVOID args); /* globals */ @@ -149,10 +155,21 @@ main( } printf("%s\n", GetVersionFromFile(argv[2], argv[3])); return 0; + case 'Q': + if (argc != 3) { + chars = snprintf(msg, sizeof(msg) - 1, + "usage: %s -Q path\n" + "Emit the fully qualified path\n" + "exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]); + WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, + &dwWritten, NULL); + return 2; + } + return QualifyPath(argv[2]); } } chars = snprintf(msg, sizeof(msg) - 1, - "usage: %s -c|-l|-f|-g|-V ...\n" + "usage: %s -c|-f|-l|-Q|-s|-V ...\n" "This is a little helper app to equalize shell differences between WinNT and\n" "Win9x and get nmake.exe to accomplish its job.\n", argv[0]); @@ -160,7 +177,7 @@ main( return 2; } -int +static int CheckForCompilerFeature( const char *option) { @@ -245,7 +262,7 @@ CheckForCompilerFeature( FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS| FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPVOID)&msg[chars], (300-chars), 0); - WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg,lstrlen(msg), &err,NULL); + WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, lstrlen(msg), &err,NULL); return 2; } @@ -294,7 +311,7 @@ CheckForCompilerFeature( || strstr(Err.buffer, "D2021") != NULL); } -int +static int CheckForLinkerFeature( const char *option) { @@ -373,7 +390,7 @@ CheckForLinkerFeature( FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_IGNORE_INSERTS| FORMAT_MESSAGE_MAX_WIDTH_MASK, 0L, err, 0, (LPVOID)&msg[chars], (300-chars), 0); - WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg,lstrlen(msg), &err,NULL); + WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, lstrlen(msg), &err,NULL); return 2; } @@ -419,7 +436,7 @@ CheckForLinkerFeature( strstr(Err.buffer, "LNK4044") != NULL); } -DWORD WINAPI +static DWORD WINAPI ReadFromPipe( LPVOID args) { @@ -444,7 +461,7 @@ ReadFromPipe( return 0; /* makes the compiler happy */ } -int +static int IsIn( const char *string, const char *substring) @@ -459,7 +476,7 @@ IsIn( * package provide or package ifneeded. */ -const char * +static const char * GetVersionFromFile( const char *filename, const char *match) @@ -565,7 +582,7 @@ list_free(list_item_t **listPtrPtr) * << */ -int +static int SubstituteFile( const char *substitutions, const char *filename) @@ -641,6 +658,30 @@ SubstituteFile( fclose(fp); return 0; } + +/* + * QualifyPath -- + * + * This composes the current working directory with a provided path + * and returns the fully qualified and normalized path. + * Mostly needed to setup paths for testing. + */ + +static int +QualifyPath( + const char *szPath) +{ + char szCwd[MAX_PATH + 1]; + char szTmp[MAX_PATH + 1]; + char *p; + GetCurrentDirectory(MAX_PATH, szCwd); + while ((p = strchr(szPath, '/')) && *p) + *p = '\\'; + PathCombine(szTmp, szCwd, szPath); + PathCanonicalize(szCwd, szTmp); + printf("%s\n", szCwd); + return 0; +} /* * Local variables: diff --git a/win/rules.vc b/win/rules.vc index f2ee135..f09e2ea 100644 --- a/win/rules.vc +++ b/win/rules.vc @@ -8,7 +8,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Copyright (c) 2001-2003 David Gravereaux. -# Copyright (c) 2003-2007 Patrick Thoyts +# Copyright (c) 2003-2008 Patrick Thoyts #------------------------------------------------------------------------------ !ifndef _RULES_VC @@ -243,9 +243,9 @@ TCL_USE_STATIC_PACKAGES = 1 TCL_USE_STATIC_PACKAGES = 0 !endif !if [nmakehlp -f $(OPTS) "nothreads"] +!message *** Compile explicitly for non-threaded tcl TCL_THREADS = 0 !else -!message *** Doing threads TCL_THREADS = 1 USE_THREAD_ALLOC= 1 !endif @@ -287,7 +287,7 @@ LOIMPACT = 0 USE_THREAD_ALLOC = 1 !endif !if [nmakehlp -f $(OPTS) "tclalloc"] -!message *** Doing thrdalloc +!message *** Doing tclalloc USE_THREAD_ALLOC = 0 !endif !if [nmakehlp -f $(OPTS) "unchecked"] @@ -598,7 +598,7 @@ TCLSTUBLIB = "$(_TCLDIR)\lib\tclstub$(TCL_VERSION).lib" TCLIMPLIB = "$(_TCLDIR)\lib\tcl$(TCL_VERSION)$(SUFX).lib" TCL_LIBRARY = $(_TCLDIR)\lib TCLREGLIB = "$(_TCLDIR)\lib\tclreg13$(SUFX:t=).lib" -TCLDDELIB = "$(_TCLDIR)\lib\tcldde13$(SUFX:t=).lib" +TCLDDELIB = "$(_TCLDIR)\lib\tcldde14$(SUFX:t=).lib" COFFBASE = \must\have\tcl\sources\to\build\this\target TCLTOOLSDIR = \must\have\tcl\sources\to\build\this\target TCL_INCLUDES = -I"$(_TCLDIR)\include" @@ -611,7 +611,7 @@ TCLSTUBLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclstub$(TCL_VERSION).lib" TCLIMPLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcl$(TCL_VERSION)$(SUFX).lib" TCL_LIBRARY = $(_TCLDIR)\library TCLREGLIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tclreg13$(SUFX:t=).lib" -TCLDDELIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcldde13$(SUFX:t=).lib" +TCLDDELIB = "$(_TCLDIR)\win\$(BUILDDIRTOP)\tcldde14$(SUFX:t=).lib" COFFBASE = "$(_TCLDIR)\win\coffbase.txt" TCLTOOLSDIR = $(_TCLDIR)\tools TCL_INCLUDES = -I"$(_TCLDIR)\generic" -I"$(_TCLDIR)\win" @@ -211,7 +211,7 @@ AC_DEFUN([SC_LOAD_TKCONFIG], [ AC_DEFUN([SC_ENABLE_SHARED], [ AC_MSG_CHECKING([how to build libraries]) AC_ARG_ENABLE(shared, - [ --enable-shared build and link with shared libraries [--enable-shared]], + [ --enable-shared build and link with shared libraries (default: on)], [tcl_ok=$enableval], [tcl_ok=yes]) if test "${enable_shared+set}" = set; then @@ -250,11 +250,11 @@ AC_DEFUN([SC_ENABLE_SHARED], [ AC_DEFUN([SC_ENABLE_THREADS], [ AC_MSG_CHECKING(for building with threads) - AC_ARG_ENABLE(threads, [ --enable-threads build with threads], + AC_ARG_ENABLE(threads, [ --enable-threads build with threads (default: on)], [tcl_ok=$enableval], [tcl_ok=yes]) if test "$tcl_ok" = "yes"; then - AC_MSG_RESULT(yes) + AC_MSG_RESULT([yes (default)]) TCL_THREADS=1 AC_DEFINE(TCL_THREADS) # USE_THREAD_ALLOC tells us to try the special thread-based @@ -297,7 +297,7 @@ AC_DEFUN([SC_ENABLE_THREADS], [ AC_DEFUN([SC_ENABLE_SYMBOLS], [ AC_MSG_CHECKING([for build with symbols]) - AC_ARG_ENABLE(symbols, [ --enable-symbols build with debugging symbols [--disable-symbols]], [tcl_ok=$enableval], [tcl_ok=no]) + AC_ARG_ENABLE(symbols, [ --enable-symbols build with debugging symbols (default: off)], [tcl_ok=$enableval], [tcl_ok=no]) # FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT. if test "$tcl_ok" = "no"; then CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)' @@ -533,8 +533,8 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ MAKE_EXE="\${CC} -o \[$]@" LIBPREFIX="lib" - extra_ldflags="$extra_ldflags -pipe" extra_cflags="$extra_cflags -pipe" + extra_ldflags="$extra_ldflags -pipe" if test "${SHARED_BUILD}" = "0" ; then # static @@ -1071,7 +1071,7 @@ AC_DEFUN([SC_BUILD_TCLSH], [ #-------------------------------------------------------------------- AC_DEFUN([SC_TCL_CFG_ENCODING], [ - AC_ARG_WITH(encoding, [ --with-encoding encoding for configuration values], with_tcencoding=${withval}) + AC_ARG_WITH(encoding, [ --with-encoding encoding for configuration values], with_tcencoding=${withval}) if test x"${with_tcencoding}" != x ; then AC_DEFINE_UNQUOTED(TCL_CFGVAL_ENCODING,"${with_tcencoding}") diff --git a/win/tclWinChan.c b/win/tclWinChan.c index 517aa20..52b9e32 100644 --- a/win/tclWinChan.c +++ b/win/tclWinChan.c @@ -940,8 +940,9 @@ TclpOpenFileChannel( } TclWinConvertError(err); if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "couldn't open \"", TclGetString(pathPtr), - "\": ", Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open \"%s\": %s", + TclGetString(pathPtr), Tcl_PosixError(interp))); } return NULL; } @@ -959,9 +960,9 @@ TclpOpenFileChannel( if (handle == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "couldn't reopen serial \"", - TclGetString(pathPtr), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't reopen serial \"%s\": %s", + TclGetString(pathPtr), Tcl_PosixError(interp))); } return NULL; } @@ -995,8 +996,9 @@ TclpOpenFileChannel( */ channel = NULL; - Tcl_AppendResult(interp, "couldn't open \"", TclGetString(pathPtr), - "\": bad file type", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open \"%s\": bad file type", + TclGetString(pathPtr))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "BAD_TYPE", NULL); break; diff --git a/win/tclWinDde.c b/win/tclWinDde.c index e40e114..23b3a8e 100644 --- a/win/tclWinDde.c +++ b/win/tclWinDde.c @@ -17,7 +17,13 @@ #include <dde.h> #include <ddeml.h> -#ifndef UNICODE +#ifdef UNICODE +# if !defined(NDEBUG) + /* test POKE server Implemented for UNICODE in debug mode only */ +# undef CBF_FAIL_POKES +# define CBF_FAIL_POKES 0 +# endif +#else # undef CP_WINUNICODE # define CP_WINUNICODE CP_WINANSI # undef Tcl_WinTCharToUtf @@ -90,7 +96,7 @@ static DWORD ddeInstance; /* The application instance handle given to us * by DdeInitialize. */ static int ddeIsServer = 0; -#define TCL_DDE_VERSION "1.4.0" +#define TCL_DDE_VERSION "1.4.0b1" #define TCL_DDE_PACKAGE_NAME "dde" #define TCL_DDE_SERVICE_NAME TEXT("TclEval") #define TCL_DDE_EXECUTE_RESULT TEXT("$TCLEVAL$EXECUTE$RESULT") @@ -157,7 +163,8 @@ Dde_Init( #ifdef UNICODE if (TclWinGetPlatformId() < VER_PLATFORM_WIN32_NT) { - Tcl_AppendResult(interp, "Win32s and Windows 9x are not supported platforms", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "Win32s and Windows 9x are not supported platforms", -1)); return TCL_ERROR; } #endif @@ -785,6 +792,53 @@ DdeServerProc( } return ddeReturn; +#if !CBF_FAIL_POKES + case XTYP_POKE: + /* + * This is a poke for a Tcl variable, only implemented in + * debug/UNICODE mode. + */ + ddeReturn = DDE_FNOTPROCESSED; + + if ((uFmt != CF_TEXT) && (uFmt != CF_UNICODETEXT)) { + return ddeReturn; + } + + for (convPtr = tsdPtr->currentConversations; (convPtr != NULL) + && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) { + /* + * Empty loop body. + */ + } + + if (convPtr && !Tcl_IsSafe(convPtr->riPtr->interp)) { + Tcl_DString ds; + Tcl_Obj *variableObjPtr; + + len = DdeQueryString(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE); + Tcl_DStringInit(&dString); + Tcl_DStringSetLength(&dString, (len + 1) * sizeof(TCHAR) - 1); + utilString = (TCHAR *) Tcl_DStringValue(&dString); + DdeQueryString(ddeInstance, ddeItem, utilString, (DWORD) len + 1, + CP_WINUNICODE); + Tcl_WinTCharToUtf(utilString, -1, &ds); + utilString = (TCHAR *) DdeAccessData(hData, &dlen); + if (uFmt == CF_TEXT) { + variableObjPtr = Tcl_NewStringObj((char *)utilString, -1); + } else { + variableObjPtr = Tcl_NewUnicodeObj(utilString, -1); + } + + Tcl_SetVar2Ex(convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL, + variableObjPtr, TCL_GLOBAL_ONLY); + + Tcl_DStringFree(&ds); + Tcl_DStringFree(&dString); + ddeReturn = (HDDEDATA) DDE_FACK; + } + return ddeReturn; + +#endif case XTYP_EXECUTE: { /* * Execute this script. The results will be saved into a list object @@ -947,8 +1001,12 @@ MakeDdeConnection( if (ddeConv == (HCONV) NULL) { if (interp != NULL) { - Tcl_AppendResult(interp, "no registered server named \"", - name, "\"", NULL); + Tcl_DString dString; + + Tcl_WinTCharToUtf(name, -1, &dString); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "no registered server named \"%s\"", Tcl_DStringValue(&dString))); + Tcl_DStringFree(&dString); Tcl_SetErrorCode(interp, "TCL", "DDE", "NO_SERVER", NULL); } return TCL_ERROR; @@ -1424,7 +1482,11 @@ DdeObjCmd( serviceName = DdeSetServerName(interp, serviceName, flags, handlerPtr); if (serviceName != NULL) { +#ifdef UNICODE Tcl_SetObjResult(interp, Tcl_NewUnicodeObj((Tcl_UniChar *) serviceName, -1)); +#else + Tcl_SetObjResult(interp, Tcl_NewStringObj(serviceName, -1)); +#endif } else { Tcl_ResetResult(interp); } @@ -1483,8 +1545,13 @@ DdeObjCmd( break; } case DDE_REQUEST: { - const char *itemString = Tcl_GetStringFromObj(objv[firstArg + 2], +#ifdef UNICODE + const TCHAR *itemString = (TCHAR *) Tcl_GetUnicodeFromObj(objv[firstArg + 2], + &length); +#else + const TCHAR *itemString = Tcl_GetStringFromObj(objv[firstArg + 2], &length); +#endif if (length == 0) { Tcl_SetObjResult(interp, @@ -1537,8 +1604,13 @@ DdeObjCmd( break; } case DDE_POKE: { - const char *itemString = Tcl_GetStringFromObj(objv[firstArg + 2], +#ifdef UNICODE + const TCHAR *itemString = (TCHAR *) Tcl_GetUnicodeFromObj(objv[firstArg + 2], &length); +#else + const TCHAR *itemString = Tcl_GetStringFromObj(objv[firstArg + 2], + &length); +#endif BYTE *dataString; if (length == 0) { @@ -1638,9 +1710,9 @@ DdeObjCmd( */ if (Tcl_IsSafe(riPtr->interp) && riPtr->handlerPtr == NULL) { - Tcl_SetResult(riPtr->interp, "permission denied: " - "a handler procedure must be defined for use in " - "a safe interp", TCL_STATIC); + Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj( + "permission denied: a handler procedure must be" + " defined for use in a safe interp", -1)); Tcl_SetErrorCode(interp, "TCL", "DDE", "SECURITY_CHECK", NULL); result = TCL_ERROR; diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index 77a5b82..80fad3e 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -1530,8 +1530,8 @@ StatError( * error. */ { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "could not read \"", TclGetString(fileName), - "\": ", Tcl_PosixError(interp), (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("could not read \"%s\": %s", + TclGetString(fileName), Tcl_PosixError(interp))); } /* @@ -1649,9 +1649,9 @@ ConvertFileNameFormat( if (splitPath == NULL || pathc == 0) { if (interp != NULL) { - Tcl_AppendResult(interp, "could not read \"", - Tcl_GetString(fileName), "\": no such file or directory", - (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "could not read \"%s\": no such file or directory", + Tcl_GetString(fileName))); errno = ENOENT; Tcl_PosixError(interp); } @@ -1941,9 +1941,9 @@ CannotSetAttribute( Tcl_Obj *fileName, /* The name of the file. */ Tcl_Obj *attributePtr) /* The new value of the attribute. */ { - Tcl_AppendResult(interp, "cannot set attribute \"", - tclpFileAttrStrings[objIndex], "\" for file \"", - Tcl_GetString(fileName), "\": attribute is readonly", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot set attribute \"%s\" for file \"%s\": attribute is readonly", + tclpFileAttrStrings[objIndex], Tcl_GetString(fileName))); errno = EINVAL; Tcl_PosixError(interp); return TCL_ERROR; diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 1f56060..a44a257 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -1048,10 +1048,9 @@ TclpMatchInDirectory( TclWinConvertError(err); if (interp != NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't read directory \"", - Tcl_DStringValue(&dsOrig), "\": ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't read directory \"%s\": %s", + Tcl_DStringValue(&dsOrig), Tcl_PosixError(interp))); } Tcl_DStringFree(&dsOrig); return TCL_ERROR; @@ -1866,8 +1865,9 @@ TclpGetCwd( if (GetCurrentDirectory(MAX_PATH, buffer) == 0) { TclWinConvertError(GetLastError()); if (interp != NULL) { - Tcl_AppendResult(interp, "error getting working directory name: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "error getting working directory name: %s", + Tcl_PosixError(interp))); } return NULL; } diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c index b59ccba..6294086 100644 --- a/win/tclWinLoad.c +++ b/win/tclWinLoad.c @@ -91,9 +91,8 @@ TclpDlopen( if (hInstance == NULL) { DWORD lastError = GetLastError(); - - Tcl_AppendResult(interp, "couldn't load library \"", - Tcl_GetString(pathPtr), "\": ", NULL); + Tcl_Obj *errMsg = Tcl_ObjPrintf("couldn't load library \"%s\": ", + Tcl_GetString(pathPtr)); /* * Check for possible DLL errors. This doesn't work quite right, @@ -109,29 +108,30 @@ TclpDlopen( case ERROR_DLL_NOT_FOUND: Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_NOT_FOUND", NULL); notFoundMsg: - Tcl_AppendResult(interp, "this library or a dependent library" - " could not be found in library path", NULL); + Tcl_AppendToObj(errMsg, "this library or a dependent library" + " could not be found in library path", -1); break; case ERROR_PROC_NOT_FOUND: Tcl_SetErrorCode(interp, "WIN_LOAD", "PROC_NOT_FOUND", NULL); - Tcl_AppendResult(interp, "A function specified in the import" - " table could not be resolved by the system. Windows" - " is not telling which one, I'm sorry.", NULL); + Tcl_AppendToObj(errMsg, "A function specified in the import" + " table could not be resolved by the system. Windows" + " is not telling which one, I'm sorry.", -1); break; case ERROR_INVALID_DLL: Tcl_SetErrorCode(interp, "WIN_LOAD", "INVALID_DLL", NULL); - Tcl_AppendResult(interp, "this library or a dependent library" - " is damaged", NULL); + Tcl_AppendToObj(errMsg, "this library or a dependent library" + " is damaged", -1); break; case ERROR_DLL_INIT_FAILED: Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_INIT_FAILED", NULL); - Tcl_AppendResult(interp, "the library initialization" - " routine failed", NULL); + Tcl_AppendToObj(errMsg, "the library initialization" + " routine failed", -1); break; default: TclWinConvertError(lastError); - Tcl_AppendResult(interp, Tcl_PosixError(interp), NULL); + Tcl_AppendToObj(errMsg, Tcl_PosixError(interp), -1); } + Tcl_SetObjResult(interp, errMsg); return TCL_ERROR; } @@ -190,7 +190,8 @@ FindSymbol( Tcl_DStringFree(&ds); } if (proc == NULL && interp != NULL) { - Tcl_AppendResult(interp, "cannot find symbol \"", symbol, "\"", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "cannot find symbol \"%s\"", symbol)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL); } return proc; @@ -286,8 +287,9 @@ TclpTempFileNameForLibrary( Tcl_MutexLock(&dllDirectoryNameMutex); if (dllDirectoryName == NULL) { if (InitDLLDirectoryName() == TCL_ERROR) { - Tcl_AppendResult(interp, "couldn't create temporary directory: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't create temporary directory: %s", + Tcl_PosixError(interp))); Tcl_MutexUnlock(&dllDirectoryNameMutex); return NULL; } diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index cc696a2..36ae58a 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -1030,8 +1030,9 @@ TclpCreateProcess( } if (startInfo.hStdInput == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "couldn't duplicate input handle: ", - Tcl_PosixError(interp), (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't duplicate input handle: %s", + Tcl_PosixError(interp))); goto end; } @@ -1065,8 +1066,9 @@ TclpCreateProcess( } if (startInfo.hStdOutput == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "couldn't duplicate output handle: ", - Tcl_PosixError(interp), (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't duplicate output handle: %s", + Tcl_PosixError(interp))); goto end; } @@ -1084,8 +1086,9 @@ TclpCreateProcess( } if (startInfo.hStdError == INVALID_HANDLE_VALUE) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "couldn't duplicate error handle: ", - Tcl_PosixError(interp), (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't duplicate error handle: %s", + Tcl_PosixError(interp))); goto end; } @@ -1129,9 +1132,9 @@ TclpCreateProcess( } if (applType == APPL_DOS) { - Tcl_AppendResult(interp, + Tcl_SetObjResult(interp, Tcl_NewStringObj( "DOS application process not supported on this platform", - (char *) NULL); + -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "DOS_APP", NULL); goto end; @@ -1158,12 +1161,12 @@ TclpCreateProcess( BuildCommandLine(execPath, argc, argv, &cmdLine); - if (CreateProcess(NULL, - (TCHAR *) Tcl_DStringValue(&cmdLine), NULL, NULL, TRUE, - (DWORD) createFlags, NULL, NULL, &startInfo, &procInfo) == 0) { + if (CreateProcess(NULL, (TCHAR *) Tcl_DStringValue(&cmdLine), + NULL, NULL, TRUE, (DWORD) createFlags, NULL, NULL, &startInfo, + &procInfo) == 0) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "couldn't execute \"", argv[0], - "\": ", Tcl_PosixError(interp), (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("couldn't execute \"%s\": %s", + argv[0], Tcl_PosixError(interp))); goto end; } @@ -1409,8 +1412,8 @@ ApplicationType( if (applType == APPL_NONE) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "couldn't execute \"", originalName, - "\": ", Tcl_PosixError(interp), (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf("couldn't execute \"%s\": %s", + originalName, Tcl_PosixError(interp))); return APPL_NONE; } @@ -1673,8 +1676,8 @@ Tcl_CreatePipe( if (!CreatePipe(&readHandle, &writeHandle, &sec, 0)) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "pipe creation failed: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "pipe creation failed: %s", Tcl_PosixError(interp))); return TCL_ERROR; } @@ -1711,8 +1714,8 @@ TclGetAndDetachPids( { PipeInfo *pipePtr; const Tcl_ChannelType *chanTypePtr; + Tcl_Obj *pidsObj; int i; - char buf[TCL_INTEGER_SPACE]; /* * Punt if the channel is not a command channel. @@ -1723,12 +1726,15 @@ TclGetAndDetachPids( return; } - pipePtr = (PipeInfo *) Tcl_GetChannelInstanceData(chan); + pipePtr = Tcl_GetChannelInstanceData(chan); + TclNewObj(pidsObj); for (i = 0; i < pipePtr->numPids; i++) { - wsprintfA(buf, "%lu", TclpGetPid(pipePtr->pidPtr[i])); - Tcl_AppendElement(interp, buf); - Tcl_DetachPids(1, &(pipePtr->pidPtr[i])); + Tcl_ListObjAppendElement(NULL, pidsObj, + Tcl_NewWideIntObj((unsigned) + TclpGetPid(pipePtr->pidPtr[i]))); + Tcl_DetachPids(1, &pipePtr->pidPtr[i]); } + Tcl_SetObjResult(interp, pidsObj); if (pipePtr->numPids > 0) { ckfree(pipePtr->pidPtr); pipePtr->numPids = 0; @@ -1875,12 +1881,26 @@ PipeClose2Proc( && (pipePtr->writeFile != NULL)) { if (pipePtr->writeThread) { /* - * 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. + * Wait for the writer thread to finish the current buffer, then + * terminate the thread and close the handles. If the channel is + * nonblocking but blocked during exit, bail out since the worker + * thread is not interruptible and we want TIP#398-fast-exit. */ + if (TclInExit() + && (pipePtr->flags & PIPE_ASYNC)) { - WaitForSingleObject(pipePtr->writable, INFINITE); + /* give it a chance to leave honorably */ + SetEvent(pipePtr->stopWriter); + + if (WaitForSingleObject(pipePtr->writable, 0) == WAIT_TIMEOUT) { + return EAGAIN; + } + + } else { + + WaitForSingleObject(pipePtr->writable, INFINITE); + + } /* * The thread may already have closed on it's own. Check its exit @@ -2628,15 +2648,13 @@ Tcl_PidObjCmd( PipeInfo *pipePtr; int i; Tcl_Obj *resultPtr; - char buf[TCL_INTEGER_SPACE]; if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "?channelId?"); return TCL_ERROR; } if (objc == 1) { - wsprintfA(buf, "%lu", (unsigned long) getpid()); - Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, -1)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj((unsigned) getpid())); } else { chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), NULL); @@ -2651,9 +2669,9 @@ Tcl_PidObjCmd( pipePtr = (PipeInfo *) Tcl_GetChannelInstanceData(chan); resultPtr = Tcl_NewObj(); for (i = 0; i < pipePtr->numPids; i++) { - wsprintfA(buf, "%lu", TclpGetPid(pipePtr->pidPtr[i])); Tcl_ListObjAppendElement(/*interp*/ NULL, resultPtr, - Tcl_NewStringObj(buf, -1)); + Tcl_NewWideIntObj((unsigned) + TclpGetPid(pipePtr->pidPtr[i]))); } Tcl_SetObjResult(interp, resultPtr); } @@ -2945,6 +2963,10 @@ PipeWriterThread( * an error, so exit. */ + if (waitResult == WAIT_OBJECT_0) { + SetEvent(infoPtr->writable); + } + break; } diff --git a/win/tclWinPort.h b/win/tclWinPort.h index c262671..c6ac2b7 100644 --- a/win/tclWinPort.h +++ b/win/tclWinPort.h @@ -14,8 +14,8 @@ #ifndef _TCLWINPORT #define _TCLWINPORT -#ifndef _WIN64 -/* See [Bug 2935503]: file mtime sets wrong time */ +#if !defined(_WIN64) && defined(BUILD_tcl) +/* See [Bug 3354324]: file mtime sets wrong time */ # define _USE_32BIT_TIME_T #endif diff --git a/win/tclWinReg.c b/win/tclWinReg.c index 565188c..6ac5caf 100644 --- a/win/tclWinReg.c +++ b/win/tclWinReg.c @@ -13,9 +13,9 @@ */ #undef STATIC_BUILD -#ifndef USE_TCL_STUBS -# define USE_TCL_STUBS -#endif +#undef USE_TCL_STUBS +#define USE_TCL_STUBS + #include "tclInt.h" #ifdef _MSC_VER # pragma comment (lib, "advapi32.lib") @@ -24,20 +24,20 @@ #ifndef UNICODE # undef Tcl_WinTCharToUtf -# define Tcl_WinTCharToUtf(a,b,c) Tcl_ExternalToUtfDString(NULL,a,b,c) +# define Tcl_WinTCharToUtf(a,b,c) Tcl_ExternalToUtfDString(NULL,a,b,c) # undef Tcl_WinUtfToTChar -# define Tcl_WinUtfToTChar(a,b,c) Tcl_UtfToExternalDString(NULL,a,b,c) -#endif +# define Tcl_WinUtfToTChar(a,b,c) Tcl_UtfToExternalDString(NULL,a,b,c) +#endif /* !UNICODE */ /* * Ensure that we can say which registry is being accessed. */ #ifndef KEY_WOW64_64KEY -#define KEY_WOW64_64KEY (0x0100) +# define KEY_WOW64_64KEY (0x0100) #endif #ifndef KEY_WOW64_32KEY -#define KEY_WOW64_32KEY (0x0200) +# define KEY_WOW64_32KEY (0x0200) #endif /* @@ -45,7 +45,7 @@ */ #ifndef MAX_KEY_LENGTH -#define MAX_KEY_LENGTH 256 +# define MAX_KEY_LENGTH 256 #endif /* @@ -58,14 +58,6 @@ #define TCL_STORAGE_CLASS DLLEXPORT /* - * The maximum length of a sub-key name. - */ - -#ifndef MAX_KEY_LENGTH -#define MAX_KEY_LENGTH 256 -#endif - -/* * The following macros convert between different endian ints. */ @@ -173,7 +165,7 @@ Registry_Init( { Tcl_Command cmd; - if (Tcl_InitStubs(interp, "8.1", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.5", 0) == NULL) { return TCL_ERROR; } @@ -535,9 +527,9 @@ DeleteValue( result = RegDeleteValue(key, (const TCHAR *)Tcl_DStringValue(&ds)); Tcl_DStringFree(&ds); if (result != ERROR_SUCCESS) { - Tcl_AppendResult(interp, "unable to delete value \"", - Tcl_GetString(valueNameObj), "\" from key \"", - Tcl_GetString(keyNameObj), "\": ", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unable to delete value \"%s\" from key \"%s\": ", + Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj))); AppendSystemError(interp, result); result = TCL_ERROR; } else { @@ -575,7 +567,8 @@ GetKeyNames( { const char *pattern; /* Pattern being matched against subkeys */ HKEY key; /* Handle to the key being examined */ - TCHAR buffer[MAX_KEY_LENGTH]; /* Buffer to hold the subkey name */ + TCHAR buffer[MAX_KEY_LENGTH]; + /* Buffer to hold the subkey name */ DWORD bufSize; /* Size of the buffer */ DWORD index; /* Position of the current subkey */ char *name; /* Subkey name */ @@ -611,9 +604,9 @@ GetKeyNames( if (result == ERROR_NO_MORE_ITEMS) { result = TCL_OK; } else { - Tcl_SetObjResult(interp, Tcl_NewObj()); - Tcl_AppendResult(interp, "unable to enumerate subkeys of \"", - Tcl_GetString(keyNameObj), "\": ", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unable to enumerate subkeys of \"%s\": ", + Tcl_GetString(keyNameObj))); AppendSystemError(interp, result); result = TCL_ERROR; } @@ -694,9 +687,9 @@ GetType( RegCloseKey(key); if (result != ERROR_SUCCESS) { - Tcl_AppendResult(interp, "unable to get type of value \"", - Tcl_GetString(valueNameObj), "\" from key \"", - Tcl_GetString(keyNameObj), "\": ", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unable to get type of value \"%s\" from key \"%s\": ", + Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj))); AppendSystemError(interp, result); return TCL_ERROR; } @@ -780,7 +773,7 @@ GetValue( * HKEY_PERFORMANCE_DATA */ - length *= 2; + length = Tcl_DStringLength(&data) * (2 / sizeof(TCHAR)); Tcl_DStringSetLength(&data, (int) length * sizeof(TCHAR)); result = RegQueryValueEx(key, nativeValue, NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length); @@ -788,9 +781,9 @@ GetValue( Tcl_DStringFree(&buf); RegCloseKey(key); if (result != ERROR_SUCCESS) { - Tcl_AppendResult(interp, "unable to get value \"", - Tcl_GetString(valueNameObj), "\" from key \"", - Tcl_GetString(keyNameObj), "\": ", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unable to get value \"%s\" from key \"%s\": ", + Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj))); AppendSystemError(interp, result); Tcl_DStringFree(&data); return TCL_ERROR; @@ -817,16 +810,16 @@ GetValue( * we get bogus data. */ - while ((p < end) - && (*((Tcl_UniChar *) p)) != 0) { + while ((p < end) && *((Tcl_UniChar *) p) != 0) { Tcl_UniChar *up; + Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf); Tcl_ListObjAppendElement(interp, resultPtr, Tcl_NewStringObj(Tcl_DStringValue(&buf), Tcl_DStringLength(&buf))); up = (Tcl_UniChar *) p; - while (*up++ != 0) {} + while (*up++ != 0) {/* empty body */} p = (char *) up; Tcl_DStringFree(&buf); } @@ -1111,8 +1104,8 @@ ParseKeyName( rootName = name; } if (!rootName) { - Tcl_AppendResult(interp, "bad key \"", name, - "\": must start with a valid root", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad key \"%s\": must start with a valid root", name)); Tcl_SetErrorCode(interp, "WIN_REG", "NO_ROOT_KEY", NULL); return TCL_ERROR; } @@ -1226,8 +1219,8 @@ RecursiveDeleteKey( } break; } else if (result == ERROR_SUCCESS) { - result = RecursiveDeleteKey(hKey, (const TCHAR *) Tcl_DStringValue(&subkey), - mode); + result = RecursiveDeleteKey(hKey, + (const TCHAR *) Tcl_DStringValue(&subkey), mode); } } Tcl_DStringFree(&subkey); @@ -1294,8 +1287,8 @@ SetValue( return TCL_ERROR; } - value = ConvertDWORD((DWORD)type, (DWORD)value); - result = RegSetValueEx(key, (TCHAR *)valueName, 0, + value = ConvertDWORD((DWORD) type, (DWORD) value); + result = RegSetValueEx(key, (TCHAR *) valueName, 0, (DWORD) type, (BYTE *) &value, sizeof(DWORD)); } else if (type == REG_MULTI_SZ) { Tcl_DString data, buf; @@ -1329,7 +1322,7 @@ SetValue( Tcl_WinUtfToTChar(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1, &buf); - result = RegSetValueEx(key, (TCHAR *)valueName, 0, + result = RegSetValueEx(key, (TCHAR *) valueName, 0, (DWORD) type, (BYTE *) Tcl_DStringValue(&buf), (DWORD) Tcl_DStringLength(&buf)); Tcl_DStringFree(&data); @@ -1338,7 +1331,7 @@ SetValue( Tcl_DString buf; const char *data = Tcl_GetStringFromObj(dataObj, &length); - data = (char *)Tcl_WinUtfToTChar(data, length, &buf); + data = (char *) Tcl_WinUtfToTChar(data, length, &buf); /* * Include the null in the length, padding if needed for Unicode. @@ -1347,7 +1340,7 @@ SetValue( Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1); length = Tcl_DStringLength(&buf) + 1; - result = RegSetValueEx(key, (TCHAR *)valueName, 0, + result = RegSetValueEx(key, (TCHAR *) valueName, 0, (DWORD) type, (BYTE *) data, (DWORD) length); Tcl_DStringFree(&buf); } else { @@ -1358,7 +1351,7 @@ SetValue( */ data = (BYTE *) Tcl_GetByteArrayFromObj(dataObj, &length); - result = RegSetValueEx(key, (TCHAR *)valueName, 0, + result = RegSetValueEx(key, (TCHAR *) valueName, 0, (DWORD) type, data, (DWORD) length); } @@ -1529,14 +1522,15 @@ ConvertDWORD( DWORD type, /* Either REG_DWORD or REG_DWORD_BIG_ENDIAN */ DWORD value) /* The value to be converted. */ { - DWORD order = 1; + const DWORD order = 1; DWORD localType; /* * Check to see if the low bit is in the first byte. */ - localType = (*((char *) &order) == 1) ? REG_DWORD : REG_DWORD_BIG_ENDIAN; + localType = (*((const char *) &order) == 1) + ? REG_DWORD : REG_DWORD_BIG_ENDIAN; return (type != localType) ? (DWORD) SWAPLONG(value) : value; } diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index 58a9eb4..9e9d1af 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -1673,12 +1673,7 @@ SerialSetOptionProc( if ((len > 2) && (strncmp(optionName, "-mode", len) == 0)) { if (!GetCommState(infoPtr->handle, &dcb)) { - if (interp != NULL) { - TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't get comm state: ", - Tcl_PosixError(interp), NULL); - } - return TCL_ERROR; + goto getStateFailed; } native = Tcl_WinUtfToTChar(value, -1, &ds); result = BuildCommDCB(native, &dcb); @@ -1686,8 +1681,9 @@ SerialSetOptionProc( if (result == FALSE) { if (interp != NULL) { - Tcl_AppendResult(interp, "bad value \"", value, - "\" for -mode: should be baud,parity,data,stop", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad value \"%s\" for -mode: should be baud,parity,data,stop", + value)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL); } return TCL_ERROR; @@ -1703,12 +1699,7 @@ SerialSetOptionProc( dcb.fAbortOnError = FALSE; if (!SetCommState(infoPtr->handle, &dcb)) { - if (interp != NULL) { - TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't set comm state: ", - Tcl_PosixError(interp), NULL); - } - return TCL_ERROR; + goto setStateFailed; } return TCL_OK; } @@ -1719,12 +1710,7 @@ SerialSetOptionProc( if ((len > 1) && (strncmp(optionName, "-handshake", len) == 0)) { if (!GetCommState(infoPtr->handle, &dcb)) { - if (interp != NULL) { - TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't get comm state: ", - Tcl_PosixError(interp), NULL); - } - return TCL_ERROR; + goto getStateFailed; } /* @@ -1759,21 +1745,16 @@ SerialSetOptionProc( dcb.fDtrControl = DTR_CONTROL_HANDSHAKE; } else { if (interp != NULL) { - Tcl_AppendResult(interp, "bad value \"", value, - "\" for -handshake: must be one of xonxoff, rtscts, " - "dtrdsr or none", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad value \"%s\" for -handshake: must be one of" + " xonxoff, rtscts, dtrdsr or none", value)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "HANDSHAKE", NULL); } return TCL_ERROR; } if (!SetCommState(infoPtr->handle, &dcb)) { - if (interp != NULL) { - TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't set comm state: ", - Tcl_PosixError(interp), NULL); - } - return TCL_ERROR; + goto setStateFailed; } return TCL_OK; } @@ -1784,12 +1765,7 @@ SerialSetOptionProc( if ((len > 1) && (strncmp(optionName, "-xchar", len) == 0)) { if (!GetCommState(infoPtr->handle, &dcb)) { - if (interp != NULL) { - TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't get comm state: ", - Tcl_PosixError(interp), NULL); - } - return TCL_ERROR; + goto getStateFailed; } if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) { @@ -1798,9 +1774,9 @@ SerialSetOptionProc( if (argc != 2) { badXchar: if (interp != NULL) { - Tcl_AppendResult(interp, "bad value for -xchar: should be " - "a list of two elements with each a single character", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad value for -xchar: should be a list of" + " two elements with each a single character", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "XCHAR", NULL); } ckfree(argv); @@ -1837,12 +1813,7 @@ SerialSetOptionProc( ckfree(argv); if (!SetCommState(infoPtr->handle, &dcb)) { - if (interp != NULL) { - TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't set comm state: ", - Tcl_PosixError(interp), NULL); - } - return TCL_ERROR; + goto setStateFailed; } return TCL_OK; } @@ -1859,9 +1830,9 @@ SerialSetOptionProc( } if ((argc % 2) == 1) { if (interp != NULL) { - Tcl_AppendResult(interp, "bad value \"", value, - "\" for -ttycontrol: should be a list of " - "signal,value pairs", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad value \"%s\" for -ttycontrol: should be " + "a list of signal,value pairs", value)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "TTYCONTROL", NULL); } ckfree(argv); @@ -1877,7 +1848,8 @@ SerialSetOptionProc( if (!EscapeCommFunction(infoPtr->handle, (DWORD) (flag ? SETDTR : CLRDTR))) { if (interp != NULL) { - Tcl_AppendResult(interp, "can't set DTR signal", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can't set DTR signal", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "TTY_SIGNAL", NULL); } @@ -1888,7 +1860,8 @@ SerialSetOptionProc( if (!EscapeCommFunction(infoPtr->handle, (DWORD) (flag ? SETRTS : CLRRTS))) { if (interp != NULL) { - Tcl_AppendResult(interp, "can't set RTS signal", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can't set RTS signal", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "TTY_SIGNAL", NULL); } @@ -1899,7 +1872,8 @@ SerialSetOptionProc( if (!EscapeCommFunction(infoPtr->handle, (DWORD) (flag ? SETBREAK : CLRBREAK))) { if (interp != NULL) { - Tcl_AppendResult(interp,"can't set BREAK signal",NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can't set BREAK signal", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "TTY_SIGNAL", NULL); } @@ -1908,9 +1882,9 @@ SerialSetOptionProc( } } else { if (interp != NULL) { - Tcl_AppendResult(interp, "bad signal name \"", argv[i], - "\" for -ttycontrol: must be DTR, RTS or BREAK", - NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad signal name \"%s\" for -ttycontrol: must be" + " DTR, RTS or BREAK", argv[i])); Tcl_SetErrorCode(interp, "TCL", "VALUE", "TTY_SIGNAL", NULL); } @@ -1949,9 +1923,9 @@ SerialSetOptionProc( if ((argc < 1) || (argc > 2) || (inSize <= 0) || (outSize <= 0)) { if (interp != NULL) { - Tcl_AppendResult(interp, "bad value \"", value, - "\" for -sysbuffer: should be a list of one or two " - "integers > 0", NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad value \"%s\" for -sysbuffer: should be " + "a list of one or two integers > 0", value)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "SYS_BUFFER", NULL); } return TCL_ERROR; @@ -1960,8 +1934,9 @@ SerialSetOptionProc( if (!SetupComm(infoPtr->handle, inSize, outSize)) { if (interp != NULL) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't setup comm buffers: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't setup comm buffers: %s", + Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -1974,22 +1949,12 @@ SerialSetOptionProc( */ if (!GetCommState(infoPtr->handle, &dcb)) { - if (interp != NULL) { - TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't get comm state: ", - Tcl_PosixError(interp), NULL); - } - return TCL_ERROR; + goto getStateFailed; } dcb.XonLim = (WORD) (infoPtr->sysBufRead*1/2); dcb.XoffLim = (WORD) (infoPtr->sysBufRead*1/4); if (!SetCommState(infoPtr->handle, &dcb)) { - if (interp != NULL) { - TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't set comm state: ", - Tcl_PosixError(interp), NULL); - } - return TCL_ERROR; + goto setStateFailed; } return TCL_OK; } @@ -2020,8 +1985,9 @@ SerialSetOptionProc( if (!SetCommTimeouts(infoPtr->handle, &tout)) { if (interp != NULL) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't set comm timeouts: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't set comm timeouts: %s", + Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -2031,6 +1997,22 @@ SerialSetOptionProc( return Tcl_BadChannelOption(interp, optionName, "mode handshake pollinterval sysbuffer timeout ttycontrol xchar"); + + getStateFailed: + if (interp != NULL) { + TclWinConvertError(GetLastError()); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get comm state: %s", Tcl_PosixError(interp))); + } + return TCL_ERROR; + + setStateFailed: + if (interp != NULL) { + TclWinConvertError(GetLastError()); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't set comm state: %s", Tcl_PosixError(interp))); + } + return TCL_ERROR; } /* @@ -2089,8 +2071,8 @@ SerialGetOptionProc( if (!GetCommState(infoPtr->handle, &dcb)) { if (interp != NULL) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't get comm state: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get comm state: %s", Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -2159,8 +2141,8 @@ SerialGetOptionProc( if (!GetCommState(infoPtr->handle, &dcb)) { if (interp != NULL) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't get comm state: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get comm state: %s", Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -2237,8 +2219,8 @@ SerialGetOptionProc( if (!GetCommModemStatus(infoPtr->handle, &status)) { if (interp != NULL) { TclWinConvertError(GetLastError()); - Tcl_AppendResult(interp, "can't get tty status: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get tty status: %s", Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -2248,10 +2230,9 @@ SerialGetOptionProc( if (valid) { return TCL_OK; - } else { - return Tcl_BadChannelOption(interp, optionName, - "mode pollinterval lasterror queue sysbuffer ttystatus xchar"); } + return Tcl_BadChannelOption(interp, optionName, + "mode pollinterval lasterror queue sysbuffer ttystatus xchar"); } /* diff --git a/win/tclWinSock.c b/win/tclWinSock.c index 97b10a3..7894920 100644 --- a/win/tclWinSock.c +++ b/win/tclWinSock.c @@ -558,8 +558,8 @@ TclpHasSockets( return TCL_OK; } if (interp != NULL) { - Tcl_AppendResult(interp, "sockets are not available on this system", - NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "sockets are not available on this system", -1)); } return TCL_ERROR; } @@ -928,8 +928,8 @@ TcpClose2Proc( break; default: if (interp) { - Tcl_AppendResult(interp, - "Socket close2proc called bidirectionally", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "Socket close2proc called bidirectionally", -1)); } return TCL_ERROR; } @@ -1280,12 +1280,9 @@ CreateSocket( } if (interp != NULL) { - Tcl_AppendResult(interp, "couldn't open socket: ", NULL); - if (errorMsg == NULL) { - Tcl_AppendResult(interp, Tcl_PosixError(interp), NULL); - } else { - Tcl_AppendResult(interp, errorMsg, NULL); - } + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't open socket: %s", + (errorMsg ? errorMsg : Tcl_PosixError(interp)))); } if (sock != INVALID_SOCKET) { @@ -1929,7 +1926,8 @@ TcpSetOptionProc( if (!SocketsEnabled()) { if (interp) { - Tcl_AppendResult(interp, "winsock is not initialized", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "winsock is not initialized", -1)); } return TCL_ERROR; } @@ -1952,8 +1950,9 @@ TcpSetOptionProc( if (rtn != 0) { TclWinConvertError(WSAGetLastError()); if (interp) { - Tcl_AppendResult(interp, "couldn't set socket option: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't set socket option: %s", + Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -1973,8 +1972,9 @@ TcpSetOptionProc( if (rtn != 0) { TclWinConvertError(WSAGetLastError()); if (interp) { - Tcl_AppendResult(interp, "couldn't set socket option: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't set socket option: %s", + Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -2032,7 +2032,8 @@ TcpGetOptionProc( if (!SocketsEnabled()) { if (interp) { - Tcl_AppendResult(interp, "winsock is not initialized", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "winsock is not initialized", -1)); } return TCL_ERROR; } @@ -2099,8 +2100,9 @@ TcpGetOptionProc( if (len) { TclWinConvertError((DWORD) WSAGetLastError()); if (interp) { - Tcl_AppendResult(interp, "can't get peername: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get peername: %s", + Tcl_PosixError(interp))); } return TCL_ERROR; } @@ -2164,8 +2166,8 @@ TcpGetOptionProc( } else { if (interp) { TclWinConvertError((DWORD) WSAGetLastError()); - Tcl_AppendResult(interp, "can't get sockname: ", - Tcl_PosixError(interp), NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't get sockname: %s", Tcl_PosixError(interp))); } return TCL_ERROR; } |