summaryrefslogtreecommitdiffstats
path: root/win
diff options
context:
space:
mode:
authorstanton <stanton>1999-04-16 00:46:29 (GMT)
committerstanton <stanton>1999-04-16 00:46:29 (GMT)
commit97464e6cba8eb0008cf2727c15718671992b913f (patch)
treece9959f2747257d98d52ec8d18bf3b0de99b9535 /win
parenta8c96ddb94d1483a9de5e340b740cb74ef6cafa7 (diff)
downloadtcl-97464e6cba8eb0008cf2727c15718671992b913f.zip
tcl-97464e6cba8eb0008cf2727c15718671992b913f.tar.gz
tcl-97464e6cba8eb0008cf2727c15718671992b913f.tar.bz2
merged tcl 8.1 branch back into the main trunk
Diffstat (limited to 'win')
-rw-r--r--win/README57
-rw-r--r--win/README.binary905
-rw-r--r--win/makefile.bc388
-rw-r--r--win/makefile.vc238
-rw-r--r--win/pkgIndex.tcl5
-rw-r--r--win/tcl.rc14
-rw-r--r--win/tclAppInit.c47
-rw-r--r--win/tclWin32Dll.c543
-rw-r--r--win/tclWinChan.c610
-rw-r--r--win/tclWinConsole.c1272
-rw-r--r--win/tclWinDde.c1287
-rw-r--r--win/tclWinError.c5
-rw-r--r--win/tclWinFCmd.c1036
-rw-r--r--win/tclWinFile.c991
-rw-r--r--win/tclWinInit.c652
-rw-r--r--win/tclWinInt.h68
-rw-r--r--win/tclWinLoad.c77
-rw-r--r--win/tclWinMtherr.c15
-rw-r--r--win/tclWinNotify.c355
-rw-r--r--win/tclWinPipe.c1588
-rw-r--r--win/tclWinPort.h371
-rw-r--r--win/tclWinReg.c420
-rw-r--r--win/tclWinSerial.c1401
-rw-r--r--win/tclWinSock.c671
-rw-r--r--win/tclWinTest.c5
-rw-r--r--win/tclWinThrd.c900
-rw-r--r--win/tclWinThrd.h21
-rw-r--r--win/tclWinTime.c122
-rw-r--r--win/tclsh.rc10
29 files changed, 10430 insertions, 3644 deletions
diff --git a/win/README b/win/README
index 383cf7e..5a42354 100644
--- a/win/README
+++ b/win/README
@@ -1,10 +1,10 @@
-Tcl 8.0.5 for Windows
+Tcl 8.1 for Windows
by Scott Stanton
Scriptics Corporation
scott.stanton@scriptics.com
-RCS: @(#) $Id: README,v 1.9 1999/02/09 03:31:55 stanton Exp $
+RCS: @(#) $Id: README,v 1.10 1999/04/16 00:48:06 stanton Exp $
1. Introduction
---------------
@@ -17,31 +17,28 @@ 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
-(http://www.scriptics.com/software/8.0.html or any of the mirror
-sites). For most users, the binary release will be much easier to
-install and use. You only need the source release if you plan to
-modify the core of Tcl, or if you need to compile with a different
-compiler. With the addition of the dynamic loading interface, it is
-no longer necessary to have the source distribution in order to build
-and use extensions.
+(ftp.scriptics.com:/pub/tcl or any of the mirror sites). For most users,
+the binary release will be much easier to install and use. You only
+need the source release if you plan to modify the core of Tcl, or if
+you need to compile with a different compiler. With the addition of
+the dynamic loading interface, it is no longer necessary to have the
+source distribution in order to build and use extensions.
3. Compiling Tcl
----------------
In order to compile Tcl for Windows, you need the following items:
- Tcl 8.0 Source Distribution (plus any patches)
+ 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/5.x
-In practice, the 8.0.5 release is built with Visual C++ 5.0
+In practice, the 8.1.a2 release is built with Visual C++ 5.0
In the "win" subdirectory of the source release, you will find two
files called "makefile.bc" and "makefile.vc". These are the makefiles
@@ -57,25 +54,26 @@ 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:
- HKEY_LOCAL_MACHINE\SOFTWARE\Scriptics\Tcl\8.0
+ HKEY_LOCAL_MACHINE\SOFTWARE\Scriptics\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 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 are on your path, in the system directory, or in the
+directory containing tclsh81.exe.
+
+Note: Tcl no longer provides support for Win32s.
4. Building Extensions
----------------------
With the Windows compilers you have to worry about how you export symbols
from DLLs. tcl.h defines a few macros to help solve this problem:
-
EXTERN - all Tcl_ function prototypes use this macro, which implies
they are exported. You'll see this used in tcl.h and tk.h.
You should use this in your exported procedures.
@@ -102,9 +100,7 @@ EXPORT(type, func)
EXPORT because they had a different order. Your declaration will
look like
EXTERN EXPORT(int, Foo_Init)(Tcl_Interp *interp);
-
We have not defined EXPORT anywhere. You can paste this into your C file:
-
#ifndef STATIC_BUILD
#if defined(_MSC_VER)
# define EXPORT(a,b) __declspec(dllexport) a b
@@ -174,16 +170,19 @@ appropriate makefile for your compiler.
Here is the current list of known bugs/missing features for the
Windows version of Tcl:
-- Blocking "after" commands (e.g. "after 3000") don't work on Win32s.
- Clock command fails to handle daylight savings time boundaries for
things like "last week".
- Background processes aren't properly detached on NT.
-- File events only work on sockets.
-- Pipes/files/console/serial ports don't support nonblocking I/O.
+- File events only work on sockets and pipes.
+- Files/console/serial ports don't support nonblocking I/O.
+- 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:
+please use the form at:
-<bugs@scriptics.com>
+http://www.scriptics.com/support/bugForm.html
-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@tclconsortium.org mailing list.
diff --git a/win/README.binary b/win/README.binary
index fc8d4a1..1112ef1 100644
--- a/win/README.binary
+++ b/win/README.binary
@@ -1,518 +1,387 @@
-Tcl/Tk 8.0.5 for Windows, Binary Distribution
-
-%Z% $Id: README.binary,v 1.3 1999/01/04 19:25:05 rjohnson Exp $
-
-1. Introduction
----------------
-
-This directory contains the binary distribution of Tcl/Tk 8.0.5 for
-Windows. It was compiled with Microsoft Visual C++ 5.0 using Win32
-API, so that it will run under Windows NT and Windows 95. The
-information here corresponds to release 8.0. This patch provides
-compatibility with [incr Tcl] 3.0. Tcl 8.0 is a major new release
-that replaces the core of the interpreter with an on-the-fly bytecode
-compiler to improve execution speed. It also includes several other
-new features such as namespaces and binary I/O, plus many bug fixes.
-The compiler introduces a few incompatibilities that may affect
-existing Tcl scripts; the incompatibilities are relatively obscure but
-may require modifications to some old scripts before they can run with
-this version. The compiler introduces many new C-level APIs, but the
-old APIs are still supported. See below for more details. This patch
-release fixes various bugs in Tcl 8.0, plus it adds a few minor
-features to support the TclPro 1.0 tool set and [incr Tcl] 3.0.
-Please check the changes file in the source release for details.
-
-This release also corresponds to Tk 8.0.5. This is a major release with
-significant new features such as native look and feel on Macintoshes
-and PCs, a new font mechanism, application embedding, and proper
-support for Safe-Tcl. See below for details. There should be no
-backward incompatibilities in Tk 8.0.5 that affect scripts.
-
-Note: with this release the Tk version number skips from 4.2 to 8.0.
-The jump was made in order to synchronize the Tcl and Tk version
-numbers.
-
-2. Documentation
-----------------
-
-The best way to get started with Tcl is to read one of the introductory
-books on Tcl:
-
- Practical Programming in Tcl and Tk, 2nd Edition, by Brent Welch,
- Prentice-Hall, 1997, ISBN 0-13-616830-2
-
- Tcl and the Tk Toolkit, by John Ousterhout,
- Addison-Wesley, 1994, ISBN 0-201-63337-X
-
- Exploring Expect, by Don Libes,
- O'Reilly and Associates, 1995, ISBN 1-56592-090-2
-
-Other books are listed at
-http://www.scriptics.com/resource/doc/books/
-http://www.tclconsortium.org/resources/books.html
-
-There is also an official home for Tcl and Tk on the Web:
- http://www.scriptics.com
-These Web pages include information about the latest releases, products
-related to Tcl and Tk, reports on bug fixes and porting issues, HTML
-versions of the manual pages, and pointers to many other Tcl/Tk Web
-pages at other sites. Check them out!
-
-3. Installation
----------------
-
-The binary release is distributed as a self-extracting archive called
-tcl80.exe. The setup program which will prompt you for an
-installation directory. It will create the installation heirarchy
-under the specified directory, and install a wish application icon
-under the program manager group of your choice.
-
-With the 8.0.3 patch release, we are no longer supporting use of
-Tcl with 16-bit versions of Windows. Microsoft has completely dropped
-support of the Win32s subsystem. If you still need 16-bit support,
-you can get win32s and the 16-bit thunking dll (tcl1680.dll) from the
-Scriptics web site at ftp://ftp.scriptics.com/pub/tcl/misc.
-
-4. Summary of changes in Tcl 8.0
---------------------------------
-
-Here are the most significant changes in Tcl 8.0. In addition to these
-changes, there are several smaller changes and bug fixes. See the file
-"changes" for a complete list of all changes.
-
- 1. Bytecode compiler. The core of the Tcl interpreter has been
- replaced with an on-the-fly compiler that translates Tcl scripts to
- byte codes; a new interpreter then executes the byte codes. In
- earlier versions of Tcl, strings were used as a universal
- representation; in Tcl 8.0 strings are replaced with Tcl_Obj
- structures ("objects") that can hold both a string value and an
- internal form such as a binary integer or compiled bytecodes. The
- new objects make it possible to store information in efficient
- internal forms and avoid the constant translations to and from
- strings that occurred with the old interpreter. We have not yet
- converted all of Tcl to take full advantage of the compiler and
- objects and have not converted any of Tk yet, but even so you
- should see speedups of 2-3x on many programs and you may see
- speedups as much as 10-20x in some cases (such as code that
- manipulates long lists). Future releases should achieve even
- greater speedups. The compiler introduces only a few minor changes
- at the level of Tcl scripts, but it introduces many new C APIs for
- managing objects. See, for example, the manual entries doc/*Obj*.3.
-
- 2. Namespaces. There is a new namespace mechanism based on the
- namespace implementation by Michael McLennan of Lucent Technologies.
- This includes new "namespace" and "variable" commands. There are
- many new C APIs associated with namespaces, but they will not be
- exported until Tcl 8.1. Note: the syntax of the namespace command
- has been changed slightly since the b1 release. See the changes
- file for details.
-
- 3. Binary I/O. The new object system in Tcl 8.0 supports binary
- strings (internally, strings are counted in addition to being null
- terminated). There is a new "binary" command for inserting and
- extracting data to/from binary strings. Commands such as "puts",
- "gets", and "read" commands now operate correctly on binary data.
- There is a new variable tcl_platform(byteOrder) to identify the
- native byte order for the current host.
-
- 4. Random numbers. The "expr" command now contains a random number
- generator, which can be accessed via the "rand()" and "srand()" math
- functions.
-
- 5. Safe-Tcl enhancements. There is a new "hidden command"
- mechanism, implemented with the Tcl commands "interp hide", "interp
- expose", "interp invokehidden", and "interp hidden" and the C APIs
- Tcl_HideCommand and Tcl_ExposeCommand. There is now support for
- loadable security policies, including new library procedures such as
- tcl_safeCreateInterp.
-
- 6. There is a new package "registry" available under Windows for
- accessing the Windows registry.
-
- 7. There is a new command "file attributes" for getting and setting
- things like permissions and owner. There is also a new command
- "file nativename" for getting back the platform-specific name for a
- particular file.
-
- 8. There is a new "fcopy" command to copy data between channels.
- This replaces and improves upon the not-so-secret unsupported old
- command "unsupported0".
-
- 9. There is a new package "http" for doing GET, POST, and HEAD
- requests via the HTTP/1.0 protocol. See the manual entry http.n
- for details.
-
- 10. There are new library procedures for finding word breaks in
- strings. See the manual entry library.n for details.
-
- 11. There are new C APIs Tcl_Finalize (for cleaning up before
- unloading the Tcl DLL) and Tcl_Ungets for pushing bytes back into a
- channel's input buffer.
-
- 12. Tcl now supports serial I/O devices on Windows and Unix, with a
- new fconfigure -mode option. The Windows driver does not yet
- support event-driven I/O.
-
- 13. The lsort command has new options -dictionary and -index. The
- -index option allows for very rapid sorting based on an element
- of a list.
-
- 14. The event notifier has been completely rewritten (again). It
- should now allow Tcl to use an external event loop (like Motif's)
- when it is embedded in other applications. No script-level
- interfaces have changed, but many of the C APIs have.
-
-Tcl 8.0 introduces the following incompatibilities that may affect Tcl
-scripts that worked under Tcl 7.6 and earlier releases:
-
- 1. Variable and command names may not include the character sequence
- "::" anymore: this sequence is now used as a namespace separator.
-
- 2. The semantics of some Tcl commands have been changed slightly to
- maximize performance under the compiler. These incompatibilities
- are documented on the Web so that we can keep the list up-to-date.
- See the URL http://www.sunlabs.com/research/tcl/compiler.html.
-
- 3. 2-digit years are now parsed differently by the "clock" command
- to handle year 2000 issues better (years 00-38 are treated as
- 2000-2038 instead of 1900-1938).
-
- 4. The old Macintosh commands "cp", "mkdir", "mv", "rm", and "rmdir"
- are no longer supported; all of these features are now available on
- all platforms via the "file" command.
-
- 5. The variable tcl_precision is now shared between interpreters
- and defaults to 12 digits instead of 6; safe interpreters cannot
- modify tcl_precision. The new object system in Tcl 8.0 causes
- floating-to-string conversions (and the associated rounding) to
- occur much less often than in Tcl 7.6, which can sometimes cause
- behavioral changes.
-
- 6. The C APIs associated with the notifier have changed substantially.
-
- 7. The procedures Tcl_CreateModalTimeout and Tcl_DeleteModalTimeout
- have been removed.
-
- 8. Tcl_CreateFileHandler and Tcl_DeleteFileHandler now take Unix
- fd's and are only supported on the Unix platform. Please use the
- Tcl_CreateChannelHandler interface instead.
-
- 9. The C APIs for creating channel drivers have changed as part of
- the new notifier implementation. The Tcl_File interfaces have been
- removed. Tcl_GetChannelFile has been replaced with
- Tcl_GetChannelHandle. Tcl_MakeFileChannel now takes a platform-
- specific file handle. Tcl_DriverGetOptionProc procedures now take
- an additional interp argument.
-
-5. Summary of changes in Tk 8.0
--------------------------------
-
-Here is a list of the most important new features in Tk 8.0. The
-release also includes several smaller feature changes and bug fixes.
-See the "changes" file for a complete list of all changes.
-
- 1. Native look and feel. The widgets have been rewritten to provide
- (nearly?) native look and feel on the Macintosh and PC. Many
- widgets, including scrollbars, menus, and the button family, are
- implemented with native platform widgets. Others, such as entries
- and texts, have been modified to emulate native look and feel.
- These changes are backwards compatible except that (a) some
- configuration options are now ignored on some platforms and (b) you
- must use the new menu mechanism described below to native look and
- feel for menus.
-
- 2. There is a new interface for creating menus, where a menubar is
- implemented as a menu widget instead of a frame containing menubuttons.
- The -menu option for a toplevel is used to specify the name of the
- menubar; the menu will be displayed *outside* the toplevel using
- different mechanisms on each platform (e.g. on the Macintosh the menu
- will appear at the top of the screen). See the menu demos in the
- widget demo for examples. The old style of menu still works, but
- does not provide native look and feel. Menus have several new
- features:
- - New "-columnbreak" and "-hideMargin" options make it possible
- to create multi-column menus.
- - It is now possible to manipulate the Apple and Help menus on
- the Macintosh, and the system menu on Windows. It is also
- possible to have a right justified Help menu on Unix.
- - Menus now issue the virtual event <<MenuSelect>> whenever the
- current item changes. Applications can use this to generate
- help messages.
- - There is a new "-direction" option for menubuttons, which
- controls where the menu pops up revenues to the button.
-
- 3. The font mechanism in Tk has been completely reworked:
- - Font names need not be nasty X LFDs: more intuitive names
- like {Times 12 Bold} can also be used. See the manual entry
- font.n for details.
- - Font requests always succeed now. If the requested font is
- not available, Tk finds the closest available font and uses
- that one.
- - Tk now supports named fonts whose precise attributes can be
- changed dynamically. If a named font is changed, any widget
- using that font updates itself to reflect the change.
- - There is a new command "font" for creating named fonts and
- querying various information about fonts.
- - There are now officially supported C APIs for measuring and
- displaying text. If you use these APIs now, your code will
- automatically handle international text when internationalization
- is added to Tk in a future release. See the manual entries
- MeasureChar.3, TextLayout.3, and FontId.3.
- - The old C procedures Tk_GetFontStruct, Tk_NameOfFontStruct,
- and Tk_FreeFontStruct have been replaced with more portable
- procedures Tk_GetFont, Tk_NameOfFont, and Tk_FreeFont.
-
- 4. Application embedding. It is now possible to embedded one Tcl/Tk
- application inside another, using the -container option on frame
- widgets and the -use option for toplevel widgets or on the command
- line for wish. Embedding should be fully functional under Unix,
- but the implementation is incomplete on the Macintosh and PC.
-
- 5. Tk now works correctly with Safe-Tcl: it can be loaded into
- safe interpreters.
-
- 6. Text widgets now allow images to be embedded directly in the
- text without using embedded windows. This is more efficient and
- provides smoother scrolling.
-
- 7. Buttons have a new -default option for drawing default rings in
- a platform-specific manner.
-
- 8. There is a new "gray75" bitmap, and the "gray25" bitmap is now
- really 25% on (due to an ancient mistake, it had been only 12% on).
- The Macintosh now supports native bitmaps, including new builtin
- bitmaps "stop", "caution", and "note", plus the ability to use
- bitmaps in the application's resource fork.
-
- 9. The "destroy" command now ignores windows that don't exist
- instead of generating an error.
-
-Tk 8.0 introduces the following incompatibilities that may affect Tcl/Tk
-scripts that worked under Tk 4.2 and earlier releases:
-
- 1. Font specifications such as "Times 12" now interpret the size
- as points, whereas it used to be pixels (this was actually a bug,
- since the behavior was documented as points). To get pixels now,
- use a negative size such as "Times -12".
-
- 2. The -transient option for menus is no longer supported. You can
- achieve the same effect with the -type field.
-
- 3. In the canvas "coords" command, polygons now return only the
- points that were explicitly specified when the polygon was created
- (they used to return an extra point if the polygon wasn't originally
- closed). Internally, polygons are still closed automatically for
- purposes of display and hit detection; the extra point just isn't
- returned by the "coords" command.
-
- 4. The photo image mechanism now uses Tcl_Channels instead of FILEs,
- in order to make it portable. FILEs are no longer used anywhere
- in Tk.
-
- 5. The procedures Tk_GetFontStruct, Tk_NameOfFontStruct,
- and Tk_FreeFontStruct have been removed.
-
-Note: the new compiler in Tcl 8.0 may also affect Tcl/Tk scripts; check
-the Tcl documentation for information on incompatibilities introduced by
-Tcl 8.0.
-
-6. Known Bugs/Missing Features
-------------------------------
-
-- Blocking "after" commands (e.g. "after 3000") don't work on Win32s.
-- Clock command fails to handle daylight savings time boundaries for
- things like "last week".
-- Background processes aren't properly detached on NT.
-- File events only work on sockets.
-- Pipes/files/console/serial ports don't support nonblocking I/O.
-- The library cannot be used by two processes at the same time under
- Win32s.
-- There is no support for custom cursors/application icons. The core
- set of X cursors is supported, although you cannot change their color.
-- Stippling of arcs isn't implemented yet.
-- Some "wm" functions don't map to Windows and aren't implemented;
- others should map, but just aren't implemented. The worst offenders
- are the icon manipulation routines.
-- Under Win32s, you can only start one instance of Wish at a time.
-- Color management on some displays doesn't work properly resulting in
- Tk switching to monochrome mode.
-- Tk seems to fail to draw anything on some Matrox Millenium cards.
-- Send and winfo interps are not currently supported
-- Printing does not work for images (e.g. GIF) on a canvas.
-- Tk_dialog appears in the upper left corner. This is a symptom of a
- larger problem with "wm geometry" when applied to unmapped or
- iconified windows.
-- Some keys don't work on international keyboards.
-- Grabs do not affect native menus or the title bar.
-- PPM images are using the wrong translation mode for writing to
- files, resulting in CR/LF terminated PPM files.
-- Tk crashes if the display depth changes while it is running. Tk
- also doesn't consistently track changes in the system colors.
-
-There may be more that we don't know about, so be sure to submit bug
-reports when you run into problems. 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 newsgroup comp.lang.tcl.
-
-7. Tcl newsgroup
------------------
-
-There is a network news group "comp.lang.tcl" intended for the exchange
-of information about Tcl, Tk, and related applications. Feel free to use
-the newsgroup both for general information questions and for bug reports.
-We read the newsgroup and will attempt to fix bugs and problems reported
-to it.
-
-When using comp.lang.tcl, please be sure that your e-mail return address
-is correctly set in your postings. This allows people to respond directly
-to you, rather than the entire newsgroup, for answers that are not of
-general interest. A bad e-mail return address may prevent you from
-getting answers to your questions. You may have to reconfigure your news
-reading software to ensure that it is supplying valid e-mail addresses.
-
-8. Tcl contributed archive
---------------------------
-
-Many people have created exciting packages and applications based on Tcl
-and/or Tk and made them freely available to the Tcl community. An archive
-of these contributions is kept on the machine ftp.neosoft.com. You
-can access the archive using anonymous FTP; the Tcl contributed archive is
-in the directory "/pub/tcl". The archive also contains several FAQ
-("frequently asked questions") documents that provide solutions to problems
-that are commonly encountered by TCL newcomers.
-
-9. Tcl Resource Center
-----------------------
-Visit http://www.scritics.com/resource/ to see an annotated index of
-many Tcl resources available on the World Wide Web. This includes
-papers, books, and FAQs, as well as extensions, applications, binary
-releases, and patches. You can contribute patches by sending them
-to <patches@scriptics.com>. You can also recommend more URLs for the
-resource center using the forms labeled "Add a Resource".
-
-10. Mailing lists
-----------------
-
-A couple of Mailing List have been set up to discuss Macintosh or
-Windows related Tcl issues. In order to use these Mailing Lists you
-must have access to the internet. To subscribe send a message to:
-
- wintcl-request@tclconsortium.org
- mactcl-request@tclconsortium.org
-
-In the body of the message (the subject will be ignored) put:
-
- subscribe mactcl Joe Blow
-
-Replacing Joe Blow with your real name, of course. (Use wintcl
-instead of mactcl if your interested in the Windows list.) If you
-would just like to receive more information about the list without
-subscribing put the line:
-
- information mactcl
-
-in the body instead (or wintcl).
-
-10. Support and bug fixes
-------------------------
-
-We're very interested in receiving bug reports and suggestions for
-improvements. We prefer that you send this information to the
-comp.lang.tcl newsgroup rather than to any of us at Sun. We'll see
-anything on comp.lang.tcl, and in addition someone else who reads
-comp.lang.tcl may be able to offer a solution. The normal turn-around
-time for bugs is 2-4 weeks. Enhancements may take longer and may not
-happen at all unless there is widespread support for them (we're
-trying to slow the rate at which Tcl turns into a kitchen sink). It's
-very difficult to make incompatible changes to Tcl at this point, due
-to the size of the installed base.
-
-When reporting bugs, please provide a short tclsh script that we can
-use to reproduce the bug. Make sure that the script runs with a
-bare-bones tclsh and doesn't depend on any extensions or other
-programs, particularly those that exist only at your site. Also,
-please include three additional pieces of information with the
-script:
- (a) how do we use the script to make the problem happen (e.g.
- what things do we click on, in what order)?
- (b) what happens when you do these things (presumably this is
- undesirable)?
- (c) what did you expect to happen instead?
-
-The Tcl community is too large for us to provide much individual
-support for users. If you need help we suggest that you post questions
-to comp.lang.tcl. We read the newsgroup and will attempt to answer
-esoteric questions for which no-one else is likely to know the answer.
-In addition, Tcl support and training are available commercially from
-NeoSoft (info@neosoft.com), Computerized Processes Unlimited
-(gwl@cpu.com), and Data Kinetics (education@dkl.com).
-
-11. Tcl version numbers
-----------------------
-
-Each Tcl release is identified by two numbers separated by a dot, e.g.
-6.7 or 7.0. If a new release contains changes that are likely to break
-existing C code or Tcl scripts then the major release number increments
-and the minor number resets to zero: 6.0, 7.0, etc. If a new release
-contains only bug fixes and compatible changes, then the minor number
-increments without changing the major number, e.g. 7.1, 7.2, etc. If
-you have C code or Tcl scripts that work with release X.Y, then they
-should also work with any release X.Z as long as Z > Y.
-
-Alpha and beta releases have an additional suffix of the form b1 or b1.
-For example, Tcl 7.0b1 is the first beta release of Tcl version 7.0,
-Tcl 7.0b2 is the second beta release, and so on. A beta release is an
-initial version of a new release, used to fix bugs and bad features before
-declaring the release stable. An alpha release is like a beta release,
-except it's likely to need even more work before it's "ready for prime
-time". New releases are normally preceded by one or more alpha and beta
-releases. We hope that lots of people will try out the alpha and beta
-releases and report problems. We'll make new alpha/beta releases to fix
-the problems, until eventually there is a beta release that appears to
-be stable. Once this occurs we'll make the final release.
-
-We can't promise to maintain compatibility among alpha and beta releases.
-For example, release 7.1b2 may not be backward compatible with 7.1b1, even
-though the final 7.1 release will be backward compatible with 7.0. This
-allows us to change new features as we find problems during beta testing.
-We'll try to minimize incompatibilities between beta releases, but if
-a major problem turns up then we'll fix it even if it introduces an
-incompatibility. Once the official release is made then there won't
-be any more incompatibilities until the next release with a new major
-version number.
-
-Patch releases have a suffix such as p1 or p2. These releases contain
-bug fixes only. A patch release (e.g Tcl 7.6p2) should be completely
-compatible with the base release from which it is derived (e.g. Tcl
-7.6), and you should normally use the highest available patch release.
-
-As of 8.0.3, the patch releases use a second . instead of 'p'. So, the
-8.0 release went to 8.0p1, 8.0p2, and 8.0.3. The alphas and betas will
-still use the 'a' and 'b' letters in their tcl_patchLevel.
-
-12. Linking against the binary release
---------------------------------------
-
-In order to link your applications against the .dll files shipped with
-this release, you will need to use the appropriate .lib file for your
-compiler. In the lib directory of the installation directory, there
-are library files for the Microsoft Visual C++ compiler:
-
- tcl80vc.lib
- tk80vc.lib
-
-13. Building dynamically loadable extensions
---------------------------------------------
-
-Please refer to the example dynamically loadable extension provided on
-our ftp site:
-
- ftp://ftp.scriptics.com/pub/tcl/misc/example.zip
-
-This archive contains a template that you can use for building
-extensions that will be loadable on Unix, Windows, and Macintosh
-systems.
+Tcl/Tk 8.1b3 for Windows, Binary Distribution
+
+RCS: @(#) $Id: README.binary,v 1.4 1999/04/16 00:48:06 stanton Exp $
+
+1. Introduction
+---------------
+
+This directory contains the binary distribution of Tcl/Tk 8.1b3 for
+Windows. It was compiled with Microsoft Visual C++ 5.0 using Win32
+API, so that it will run under Windows NT and Windows 95. The
+information here corresponds to the second beta release of 8.1.
+
+2. Documentation
+----------------
+
+The best way to get started with Tcl is to read one of the introductory
+books on Tcl:
+
+ Practical Programming in Tcl and Tk, 2nd Edition, by Brent Welch,
+ Prentice-Hall, 1997, ISBN 0-13-616830-2
+
+ Tcl and the Tk Toolkit, by John Ousterhout,
+ Addison-Wesley, 1994, ISBN 0-201-63337-X
+
+ Exploring Expect, by Don Libes,
+ O'Reilly and Associates, 1995, ISBN 1-56592-090-2
+
+Other books are listed at
+http://www.scriptics.com/resource/doc/books/
+http://www.tclconsortium.org/resources/books.html
+
+There is also an official home for Tcl and Tk on the Web:
+ http://www.scriptics.com
+These Web pages include information about the latest releases, products
+related to Tcl and Tk, reports on bug fixes and porting issues, HTML
+versions of the manual pages, and pointers to many other Tcl/Tk Web
+pages at other sites. Check them out!
+
+3. Installation
+---------------
+
+The binary release is distributed as a self-extracting archive called
+tcl81.exe. The setup program which will prompt you for an
+installation directory. It will create the installation heirarchy
+under the specified directory, and install a wish application icon
+under the program manager group of your choice.
+
+We are no longer supporting use of Tcl with 16-bit versions of
+Windows. Microsoft has completely dropped support of the Win32s
+subsystem.
+
+4. Summary of changes in Tcl 8.1
+--------------------------------
+The most important changes in Tcl 8.1 are summarized below. See
+the README and changes files in the distribution
+for more complete information on what has changed, including both feature
+changes and bug fixes.
+
+Internationalization. Tcl has undergone a major
+revision to support international character sets:
+
+
+All strings in Tcl are now represented in UTF-8 instead of ASCII, so
+that Tcl now supports the full Unicode character set.
+The representation of ASCII characters is unchanged (in UTF-8 anything
+that looks like an ASCII character is an ASCII character), but
+characters with the high-order bit set, such as those in ISO-8859,
+are represented with multi-byte sequences, as are all Unicode
+characters with values greater than 127. This change does not affect
+Tcl scripts but it does affect C code that parses strings.
+Tcl automatically translates between UTF-8 and the normal encoding for
+the platform during interactions with the system.
+
+In Tcl scripts the backslash sequence \u can be used to enter
+16-bit Unicode characters. \o and \x generate
+only 8-bit characters as before.
+
+The fconfigure command now supports a -encoding
+option for specifying the encoding of an open file or socket. Tcl will
+automatically translate between the specified encoding and UTF-8 during
+I/O. See the directory library/encoding to find out what encodings are
+supported (eventually there will be an encoding command
+that makes this information more accessible).
+
+There are several new C APIs that support UTF-8 and various encodings.
+See the manual entry Utf.3 for procedures that
+translate between Unicode and UTF-8 and manipulate UTF-8 strings.
+See Encoding.3 for procedures that create new encodings and
+translate between encodings. See ToUpper.3 for procedures
+that perform case conversions on UTF-8 strings.
+
+Binary data. Binary data is handled differently in Tcl 8.1 than in
+Tcl 8.0. Tcl 8.1 uses the UTF-8 facilities to represent binary data:
+the character value zero is represented with a multi-byte sequence, so
+that (once again) strings in Tcl 8.1 never contain null bytes. This
+means that binary data is now accepted everywhere in Tcl and Tk (in
+Tcl 8.0 the support for binary data was incomplete). If you have C
+code that needs to manipulate the bytes of binary data (as opposed to
+just passing the data through) you should use a new object type called
+"byte array". See the manual entry ByteArrObj.3 for information about
+procedures such as Tcl_GetByteArrayFromObj.
+
+New regular expressions. Tcl 8.1 contains a brand new implementation
+of regular expressions from Henry Spencer. This new version supports
+almost all of the Perl extensions and it also handles UTF-8 and binary
+data.
+
+Multi-Threading. Tcl 8.1 is multi-thread safe. Each thread can
+contain several Tcl interpreters, but a given interpreter can not be
+accessed from more than one thread. Each thread runs its own event
+loop, and you can post events to other threads. There is not yet
+support for tcl level use of threading except for a test
+command. (Compile tcltest and try testthread.) Tk 8.1 is not yet
+multi-thread safe, and may never be due to limitations of Xlib.
+
+
+What's new in Tk 8.1
+
+The most important changes in Tk 8.1 are summarized below. See the
+README and changes files in the distribution for more complete
+information on what has changed, including both feature changes and
+bug fixes.
+
+1. Internationalization. Tk has undergone a major overhaul to support
+the new internationalization features of Tcl. The font package has
+been rewritten to support arbitrary Unicode characters; when you
+specify a particular font such as "Times 12" Tk may actually use
+additional fonts to display Unicode characters that don't exist in the
+font you chose. Tk guarantees to find a way to display any Unicode
+character regardless of the font you selected, as long as there is
+some font in the system that contains the Unicode character. The
+input method support in Tk has also been modified to support full
+Unicode characters.
+
+2. Send/DDE support. The send command now works on Windows platforms.
+It is implemented using DDE and there is a new dde command that allows
+Tk applications to use DDE to communicate with other Windows
+applications. send still doesn't work on the Macintosh.
+
+3. Configuration options. There is a new library of C procedures for
+manipulating widget configuration options using Tcl_Objs instead of
+strings. This should eventually make Tk much more efficient. Label,
+button, checkbutton, radiobutton, and menu widgets have been modified
+to use the new library. See SetOptions.3 for information on the new C
+APIs.
+
+4. More Tcl_Obj support. Several additional C library procedures have
+been added to support Tcl_Objs. See the manual entries 3DBorder.3,
+GetAnchor.3, GetBitmap.3, GetColor.3, GetCursor.3, GetFont.3,
+GetJustify.3, and GetPixels.3.
+
+Incompatibilities
+
+Although the 8.1 releases involve substantial changes to the
+implementation of Tcl and Tk, the changes should introduce few
+if any compatibility problems for Tcl scripts or extensions. Here
+are the compatibility problems that we know of:
+
+The changes to the regular expression package required a few minor
+syntax changes in order to support all the new features:
+
+- Backslash inside brackets is an escape whereas before it was a
+ literal character. To specify a literal \ in brackets you must
+ write \\.
+
+- Some escapes, such as \d, \s, and \w, now mean special things in a
+ bracket expression. Other escapes , such as \D, \S, \W, \A and \Z,
+ are illegal.
+
+- A { followed by a digit will no longer match those two characters.
+ Instead, it will start a bound. Such sequences should be rare and
+ will often result in an error because the following characters will
+ not look like a valid bound.
+
+- Backslash followed by an alphanumeric character is either an escape
+ or an error. Several of the new escapes were treated as literal
+ characters in earlier versions of Tcl.
+
+- The matching order has changed slightly. Here is an explanation
+ from Henry Spencer:
+
+ Both the old package and the new package find the match that starts
+ earliest in the string. Where things get tricky is when there is more
+ than one possible match starting at that point, different in either
+ length or internal details (that is, which subexpressions match where).
+
+ The old package examines possible matches in a complex but well-defined
+ order, and simply reports the first one it finds. The new package
+ examines all possible matches simultaneously, and reports the longest.
+ For example, (week|wee)(night|knights) matches all of "weeknights".
+
+ When two possible matches are of the same length, priority is decided
+ based on getting the longest possible matches for early subexpressions,
+ with later subexpressions accepting whatever they can get. This means
+ that either (wee|week)(kly|ly) or (week*)(k?ly) matches "weekly" as
+ week-ly, not wee-kly. More subtly, when .*|a.c matches "abc", the .*
+ matches the whole string and the a.c doesn't even get a chance to
+ participate.
+
+ When non-greedy quantifiers are used, things get more complicated. If
+ all quantifiers in a regular expression are non-greedy, the exact same
+ rules apply except with "longest" replaced by "shortest" everywhere.
+ When greedy and non-greedy quantifiers are mixed, it's complicated and
+ difficult to explain.
+
+Known Problems With These Releases
+
+Both the internationalization support and the new regular expression
+package are large, complicated, and young, which means there are
+likely to be lots of bugs. We need your help in finding and fixing
+problems. This is particularly important for internationalization,
+since we don't have the right equipment or knowledge to test
+under very many conditions. Here are some of the most glaring bugs
+or missing features that we know of:
+
+- We haven't been able to test input methods in Tk under Unix to be
+ sure that the full Unicode character set is being substituted
+ properly in %A substitutions. This means that it probably doesn't
+ work. We have been able to test under Windows and the Macintosh.
+
+- In Tk, PostScript generation does not work correctly for characters
+ outside the ASCII subset.
+
+- The threading for Tcl is brand new so there are likely to be bugs,
+ although it is based on early work done by Richard Hipp. We have
+ done some testing on a multiprocessor Solaris machine, but none on
+ Windows or other flavors of UNIX on a multiprocessor.
+
+6. Known Bugs/Missing Features
+------------------------------
+
+- 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 and pipes.
+- Files/console/serial ports don't support nonblocking I/O.
+- There is no support for custom cursors/application icons. The core
+ set of X cursors is supported, although you cannot change their color.
+- Stippling of arcs isn't implemented yet.
+- Some "wm" functions don't map to Windows and aren't implemented;
+ others should map, but just aren't implemented. The worst offenders
+ are the icon manipulation routines.
+- Color management on some displays doesn't work properly resulting in
+ Tk switching to monochrome mode.
+- Tk seems to fail to draw anything on some Matrox Millenium cards.
+- Printing does not work for images (e.g. GIF) on a canvas.
+- Tk_dialog appears in the upper left corner. This is a symptom of a
+ larger problem with "wm geometry" when applied to unmapped or
+ iconified windows.
+- PPM images are using the wrong translation mode for writing to
+ files, resulting in CR/LF terminated PPM files.
+- Tk crashes if the display depth changes while it is running. Tk
+ also doesn't consistently track changes in the system colors.
+
+There may be more that we don't know about, so be sure to submit bug
+reports when you run into problems. If you have comments or bug
+reports for the Windows version of Tcl, please use our on-line bug
+form at:
+
+http://www.scriptics.com/support/bugForm.html
+
+or post them to the newsgroup comp.lang.tcl.
+
+7. Tcl newsgroup
+-----------------
+
+There is a network news group "comp.lang.tcl" intended for the exchange
+of information about Tcl, Tk, and related applications. Feel free to use
+the newsgroup both for general information questions and for bug reports.
+We read the newsgroup and will attempt to fix bugs and problems reported
+to it.
+
+When using comp.lang.tcl, please be sure that your e-mail return address
+is correctly set in your postings. This allows people to respond directly
+to you, rather than the entire newsgroup, for answers that are not of
+general interest. A bad e-mail return address may prevent you from
+getting answers to your questions. You may have to reconfigure your news
+reading software to ensure that it is supplying valid e-mail addresses.
+
+8. Tcl contributed archive
+--------------------------
+
+Many people have created exciting packages and applications based on Tcl
+and/or Tk and made them freely available to the Tcl community. An archive
+of these contributions is kept on the machine ftp.neosoft.com. You
+can access the archive using anonymous FTP; the Tcl contributed archive is
+in the directory "/pub/tcl". The archive also contains several FAQ
+("frequently asked questions") documents that provide solutions to problems
+that are commonly encountered by TCL newcomers.
+
+9. Tcl Resource Center
+----------------------
+Visit http://www.scritics.com/resource/ to see an annotated index of
+many Tcl resources available on the World Wide Web. This includes
+papers, books, and FAQs, as well as extensions, applications, binary
+releases, and patches. You can contribute patches by sending them
+to <patches@scriptics.com>. You can also recommend more URLs for the
+resource center using the forms labeled "Add a Resource".
+
+10. Mailing lists
+----------------
+
+A couple of Mailing List have been set up to discuss Macintosh or
+Windows related Tcl issues. In order to use these Mailing Lists you
+must have access to the internet. To subscribe send a message to:
+
+ wintcl-request@tclconsortium.org
+ mactcl-request@tclconsortium.org
+
+In the body of the message (the subject will be ignored) put:
+
+ subscribe mactcl Joe Blow
+
+Replacing Joe Blow with your real name, of course. (Use wintcl
+instead of mactcl if your interested in the Windows list.) If you
+would just like to receive more information about the list without
+subscribing put the line:
+
+ information mactcl
+
+in the body instead (or wintcl).
+
+11. Tcl version numbers
+----------------------
+
+Each Tcl release is identified by two numbers separated by a dot, e.g.
+6.7 or 7.0. If a new release contains changes that are likely to break
+existing C code or Tcl scripts then the major release number increments
+and the minor number resets to zero: 6.0, 7.0, etc. If a new release
+contains only bug fixes and compatible changes, then the minor number
+increments without changing the major number, e.g. 7.1, 7.2, etc. If
+you have C code or Tcl scripts that work with release X.Y, then they
+should also work with any release X.Z as long as Z > Y.
+
+Alpha and beta releases have an additional suffix of the form b1 or b1.
+For example, Tcl 7.0b1 is the first beta release of Tcl version 7.0,
+Tcl 7.0b2 is the second beta release, and so on. A beta release is an
+initial version of a new release, used to fix bugs and bad features before
+declaring the release stable. An alpha release is like a beta release,
+except it's likely to need even more work before it's "ready for prime
+time". New releases are normally preceded by one or more alpha and beta
+releases. We hope that lots of people will try out the alpha and beta
+releases and report problems. We'll make new alpha/beta releases to fix
+the problems, until eventually there is a beta release that appears to
+be stable. Once this occurs we'll make the final release.
+
+We can't promise to maintain compatibility among alpha and beta releases.
+For example, release 7.1b2 may not be backward compatible with 7.1b1, even
+though the final 7.1 release will be backward compatible with 7.0. This
+allows us to change new features as we find problems during beta testing.
+We'll try to minimize incompatibilities between beta releases, but if
+a major problem turns up then we'll fix it even if it introduces an
+incompatibility. Once the official release is made then there won't
+be any more incompatibilities until the next release with a new major
+version number.
+
+Patch releases have a suffix such as p1 or p2. These releases contain
+bug fixes only. A patch release (e.g Tcl 7.6p2) should be completely
+compatible with the base release from which it is derived (e.g. Tcl
+7.6), and you should normally use the highest available patch release.
+
+As of 8.0.3, the patch releases use a second . instead of 'p'. So, the
+8.0 release went to 8.0p1, 8.0p2, and 8.0.3. The alphas and betas will
+still use the 'a' and 'b' letters in their tcl_patchLevel.
+
+12. Linking against the binary release
+--------------------------------------
+
+In order to link your applications against the .dll files shipped with
+this release, you will need to use the appropriate .lib file for your
+compiler. In the lib directory of the installation directory, there
+are library files for the Microsoft Visual C++ compiler:
+
+ tcl81.lib
+ tk81.lib
+
+13. Building dynamically loadable extensions
+--------------------------------------------
+
+Please refer to the example dynamically loadable extension provided on
+our ftp site:
+
+ ftp://ftp.scriptics.com/pub/tcl/misc/example.zip
+
+This archive contains a template that you can use for building
+extensions that will be loadable on Unix, Windows, and Macintosh
+systems.
diff --git a/win/makefile.bc b/win/makefile.bc
deleted file mode 100644
index 78eebaf..0000000
--- a/win/makefile.bc
+++ /dev/null
@@ -1,388 +0,0 @@
-# Copyright (c) 1995-1996 Sun Microsystems, Inc.
-# RCS: @(#) $Id: makefile.bc,v 1.3 1998/09/14 18:40:19 stanton Exp $
-#
-# Borland C++ 4.5 makefile
-#
-
-#
-# Project directories
-#
-# ROOT = top of source tree
-# TMPDIR = location where .obj files should be stored during build
-# TOOLS = location of compiler and other development tools
-#
-
-ROOT = ..
-TMPDIR = .
-TOOLS = c:\bc45
-
-# uncomment the following line to compile with symbols
-#DEBUG=1
-
-# uncomment one of the following lines to compile with TCL_MEM_DEBUG,
-# TCL_COMPILE_DEBUG, or TCL_COMPILE_STATS
-#DEBUGDEFINES =TCL_MEM_DEBUG
-#DEBUGDEFINES =TCL_MEM_DEBUG;TCL_COMPILE_DEBUG
-#DEBUGDEFINES =TCL_MEM_DEBUG;TCL_COMPILE_STATS
-#DEBUGDEFINES =TCL_MEM_DEBUG;TCL_COMPILE_DEBUG;TCL_COMPILE_STATS
-
-
-######################################################################
-# Do not modify below this line
-######################################################################
-
-STACKSIZE = 1f0001
-
-VERSION = 80
-
-TCLLIB = tcl$(VERSION).lib
-TCLDLL = tcl$(VERSION).dll
-TCL16DLL = tcl16$(VERSION).dll
-TCLSH = tclsh$(VERSION).exe
-TCLTEST = tcltest.exe
-DUMPEXTS = dumpexts.exe
-TCLPIPEDLL = tclpip$(VERSION).dll
-TCLREGDLL = tclreg$(VERSION).dll
-CAT16 = cat16.exe
-CAT32 = cat32.exe
-
-TCLSHOBJS = \
- $(TMPDIR)\tclAppInit.obj
-
-TCLTESTOBJS = \
- $(TMPDIR)\tclTest.obj \
- $(TMPDIR)\tclTestObj.obj \
- $(TMPDIR)\tclWinTest.obj \
- $(TMPDIR)\testMain.obj
-
-TCLOBJS = \
- $(TMPDIR)\panic.obj \
- $(TMPDIR)\regexp.obj \
- $(TMPDIR)\strftime.obj \
- $(TMPDIR)\tclAlloc.obj \
- $(TMPDIR)\tclAsync.obj \
- $(TMPDIR)\tclBasic.obj \
- $(TMPDIR)\tclBinary.obj \
- $(TMPDIR)\tclCkalloc.obj \
- $(TMPDIR)\tclClock.obj \
- $(TMPDIR)\tclCmdAH.obj \
- $(TMPDIR)\tclCmdIL.obj \
- $(TMPDIR)\tclCmdMZ.obj \
- $(TMPDIR)\tclCompExpr.obj \
- $(TMPDIR)\tclCompile.obj \
- $(TMPDIR)\tclDate.obj \
- $(TMPDIR)\tclEnv.obj \
- $(TMPDIR)\tclEvent.obj \
- $(TMPDIR)\tclExecute.obj \
- $(TMPDIR)\tclFCmd.obj \
- $(TMPDIR)\tclFileName.obj \
- $(TMPDIR)\tclGet.obj \
- $(TMPDIR)\tclHash.obj \
- $(TMPDIR)\tclHistory.obj \
- $(TMPDIR)\tclIndexObj.obj \
- $(TMPDIR)\tclInterp.obj \
- $(TMPDIR)\tclIO.obj \
- $(TMPDIR)\tclIOCmd.obj \
- $(TMPDIR)\tclIOSock.obj \
- $(TMPDIR)\tclIOUtil.obj \
- $(TMPDIR)\tclLink.obj \
- $(TMPDIR)\tclListObj.obj \
- $(TMPDIR)\tclLoad.obj \
- $(TMPDIR)\tclMain.obj \
- $(TMPDIR)\tclNamesp.obj \
- $(TMPDIR)\tclNotify.obj \
- $(TMPDIR)\tclObj.obj \
- $(TMPDIR)\tclParse.obj \
- $(TMPDIR)\tclPipe.obj \
- $(TMPDIR)\tclPkg.obj \
- $(TMPDIR)\tclPosixStr.obj \
- $(TMPDIR)\tclPreserve.obj \
- $(TMPDIR)\tclProc.obj \
- $(TMPDIR)\tclResolve.obj \
- $(TMPDIR)\tclStringObj.obj \
- $(TMPDIR)\tclTimer.obj \
- $(TMPDIR)\tclUtil.obj \
- $(TMPDIR)\tclVar.obj \
- $(TMPDIR)\tclWin32Dll.obj \
- $(TMPDIR)\tclWinChan.obj \
- $(TMPDIR)\tclWinError.obj \
- $(TMPDIR)\tclWinFCmd.obj \
- $(TMPDIR)\tclWinFile.obj \
- $(TMPDIR)\tclWinInit.obj \
- $(TMPDIR)\tclWinLoad.obj \
- $(TMPDIR)\tclWinMtherr.obj \
- $(TMPDIR)\tclWinNotify.obj \
- $(TMPDIR)\tclWinPipe.obj \
- $(TMPDIR)\tclWinSock.obj \
- $(TMPDIR)\tclWinTime.obj
-
-cc32 = $(TOOLS)\bin\bcc32.exe
-link32 = $(TOOLS)\bin\tlink32.exe
-rc32 = $(TOOLS)\bin\brcc32.exe
-implib = $(TOOLS)\bin\implib.exe
-
-cc16 = $(TOOLS)\bin\bcc.exe
-link16 = $(TOOLS)\bin\tlink.exe
-rc16 = $(TOOLS)\bin\brcc32.exe -31
-
-CP = copy
-RM = del
-
-WINDIR = $(ROOT)\win
-GENERICDIR = $(ROOT)\generic
-
-INCLUDES = $(TOOLS)\include;$(WINDIR);$(GENERICDIR)
-LIBDIRS = $(TOOLS)\lib;$(WINDIR)
-
-CON_CFLAGS = +cfgexe.cfg -WC
-TEST_CFLAGS = +cfgtest.cfg
-DLL16_CFLAGS = $(PROJECTCCFLAGS) -I$(INCLUDES) -D$(DEFINES) -WD -ml -c \
- -3 -d -w
-TCL_CFLAGS = +cfgdll.cfg
-
-CON_LFLAGS = -Tpe -ap -c $(DEBUGLDFLAGS) $(TOOLS)\lib\c0x32
-DLL_LFLAGS = -Tpd -aa -c $(DEBUGLDFLAGS) $(TOOLS)\lib\c0d32
-GUI_LFLAGS = -Tpe -aa -c $(DEBUGLDFLAGS) $(TOOLS)\lib\c0w32
-DLL16_LFLAGS = -Twd -c -C -A=16 $(DEBUGLDFLAGS16) $(TOOLS)\lib\c0dl
-
-DLL_LIBS = import32 cw32mti
-CON_LIBS = $(TCLLIB) import32 cw32mti
-DLL16_LIBS = import cwl
-
-!ifndef DEBUG
-
-# these macros cause maximum optimization and no symbols
-DEBUGLDFLAGS =
-DEBUGCCFLAGS = -v- -vi- -O2
-DEBUGLDFLAGS16 = -Oc -Oi -Oa -Or
-!else
-
-# these macros enable debugging
-DEBUGLDFLAGS = -v
-DEBUGCCFLAGS = -k -Od -v
-DEBUGLDFLAGS16 =
-
-!endif
-
-DEFINES = MT;_RTLDLL;$(DEBUGDEFINES)
-PROJECTCCFLAGS = $(DEBUGCCFLAGS) -w-par -w-stu
-
-
-#
-# Global makefile settings
-#
-
-.AUTODEPEND
-.CACHEAUTODEPEND
-
-.suffixes:
-
-#.path.c=$(ROOT)\win;$(ROOT)\generic;$(ROOT)\compat
-#.path.obj=$(TMPDIR)
-#.path.dll=$(ROOT)\win
-
-#
-# Targets
-#
-
-release: $(TCLSH) dlls
-all: $(TCLSH) dlls $(CAT16) $(CAT32)
-tcltest: $(TCLTEST) dlls $(CAT16) $(CAT32)
-dlls: $(TCL16DLL) $(TCLPIPEDLL) $(TCLREGDLL)
-
-test: tcltest
- $(TCLTEST) &&|
- cd ../tests
- source all
-|
-
-
-$(DUMPEXTS): cfgexe.cfg $(WINDIR)\winDumpExts.c
- $(cc32) $(CON_CFLAGS) $(WINDIR)\winDumpExts.c
- $(link32) $(CON_LFLAGS) \
- $(TMPDIR)\winDumpExts.obj,$@,,import32 cw32mti,,
-
-$(TCLLIB): $(TCLDLL)
- $(implib) -c $@ $(TCLDLL)
-
-$(TCLDLL): cfgdll.cfg $(TCLOBJS) $(TMPDIR)\tcl.def $(TMPDIR)\tcl.res
- $(link32) $(DLL_LFLAGS) @&&|
- $(TCLOBJS)
-$@
--x
-$(DLL_LIBS)
-|, $(TMPDIR)\tcl.def, $(TMPDIR)\tcl.res
-
-
-$(TCLSH): cfgexe.cfg $(TCLSHOBJS) $(TCLLIB) $(TMPDIR)\tclsh.res
- $(link32) -S:$(STACKSIZE) $(CON_LFLAGS) @&&|
- $(TCLSHOBJS)
-$@
--x
-$(CON_LIBS)
-|, &&|
-EXETYPE WINDOWS
-CODE PRELOAD MOVEABLE DISCARDABLE
-DATA PRELOAD MOVEABLE MULTIPLE
-|, $(TMPDIR)\tclsh.res
-
-$(TCLTEST): cfgtest.cfg $(TCLTESTOBJS) $(TCLLIB) $(TMPDIR)\tclsh.res
- $(link32) -S:$(STACKSIZE) $(CON_LFLAGS) @&&|
- $(TCLTESTOBJS)
-$@
--x
-$(CON_LIBS)
-|, &&|
-EXETYPE WINDOWS
-CODE PRELOAD MOVEABLE DISCARDABLE
-DATA PRELOAD MOVEABLE MULTIPLE
-|, $(TMPDIR)\tclsh.res
-
-
-$(TCL16DLL): tcl16.rc $(ROOT)\win\tclWin16.c
- $(cc16) @&&|
-$(DLL16_CFLAGS) -n$(TMPDIR)
-| $(ROOT)\win\tclWin16.c
- $(rc16) @&&|
--i$(INCLUDES) -d__WIN32__;$(DEFINES) -fo$(TMPDIR)\tcl16.res
-| tcl16.rc
- @copy >nul &&|
-LIBRARY $&;dll
-EXETYPE WINDOWS
-CODE PRELOAD MOVEABLE DISCARDABLE
-DATA PRELOAD MOVEABLE SINGLE
-HEAPSIZE 1024
-EXPORTS
- WEP @1 RESIDENTNAME
- UTPROC @2
-| $(TMPDIR)\tclWin16.def
- $(link16) $(DLL16_LFLAGS) @&&|
-$(TMPDIR)\tclWin16.obj
-$@
-nul
-$(DLL16_LIBS)
-$(TMPDIR)\tclWin16.def
-|
- $(TOOLS)\bin\rlink $(TMPDIR)\tcl16.res $@
-
-$(TCLPIPEDLL): cfgexe.cfg stub16.c
- $(cc32) -c -tWC stub16.c
- $(link32) $(CON_LFLAGS) -L$(TOOLS)\lib \
- stub16.obj,$@,,import32 cw32,,
-
-$(TCLREGDLL): extdll.cfg $(TMPDIR)\tclWinReg.obj
- $(link32) $(DLL_LFLAGS) @&&|
- $(TMPDIR)\tclWinReg.obj
-$@
--x
-$(DLL_LIBS) $(TCLLIB)
-|,,
-
-#
-# Special test targets
-#
-
-$(CAT32): cat.c
- $(cc32) -c -Ox -tWC -ocat32.obj cat.c
- $(link32) $(CON_LFLAGS) -L$(TOOLS)\lib \
- cat32.obj,$@,,import32 cw32,,
-
-$(CAT16): cat.c
- $(cc16) -W- -ml -Ox -c -ocat16.obj cat.c
- $(link16) -Tde -c -L$(TOOLS)\lib $(TOOLS)\lib\c0l.obj cat16.obj,cat16.exe,,cl.lib,,
-
-#######################################################################
-# Implicit Targets
-#######################################################################
-
-
-{$(WINDIR)}.c{$(TMPDIR)}.obj:
- @$(cc32) $(TCL_CFLAGS) {$< }
-
-{$(GENERICDIR)}.c{$(TMPDIR)}.obj:
- @$(cc32) $(TCL_CFLAGS) {$< }
-
-{$(ROOT)\compat}.c{$(TMPDIR)}.obj:
- @$(cc32) $(TCL_CFLAGS) {$< }
-
-{$(WINDIR)}.rc{$(TMPDIR)}.res:
- $(rc32) -i$(INCLUDES) -fo$@ @&&|
--d__WIN32__;$(DEFINES) $<
-|
-
-#
-# Special case object file targets
-#
-
-$(TMPDIR)\tclWinReg.obj : extdll.cfg $(ROOT)\win\tclWinReg.c
- $(cc32) +extdll.cfg -o$@ $(ROOT)\win\tclWinReg.c
-
-$(TMPDIR)\tclAppInit.obj : cfgexe.cfg $(ROOT)\win\tclAppInit.c
- $(cc32) $(CON_CFLAGS) -o$@ $(ROOT)\win\tclAppInit.c
-
-$(TMPDIR)\testMain.obj : cfgexe.cfg $(ROOT)\win\tclAppInit.c
- $(cc32) $(TEST_CFLAGS) -o$@ $(ROOT)\win\tclAppInit.c
-
-$(TMPDIR)\tclWin16.obj : $(ROOT)\win\tclWin16.c
- $(cc16) $(DLL16_CFLAGS) -o$@ $(ROOT)\win\tclWin16.c
-
-#
-# Configuration file targets - these files are implicitly used by the compiler
-#
-
-cfgdll.cfg:
- @$(CP) &&|
- -n$(TMPDIR) -I$(INCLUDES) -c -WM
- -D$(DEFINES) -3 -d -w $(PROJECTCCFLAGS)
-| cfgdll.cfg >NUL
-
-extdll.cfg:
- @$(CP) &&|
- -n$(TMPDIR) -I$(INCLUDES) -c -WD
- -D_RTLDLL;$(DEBUGDEFINES) -3 -d -w $(PROJECTCCFLAGS)
-| extdll.cfg >NUL
-
-cfgexe.cfg:
- @$(CP) &&|
- -n$(TMPDIR) -I$(INCLUDES) -c -W
- -D$(DEFINES) -3 -d -w $(PROJECTCCFLAGS)
-| cfgexe.cfg >NUL
-
-cfgtest.cfg:
- @$(CP) &&|
- -n$(TMPDIR) -I$(INCLUDES) -c -W
- -D$(DEFINES);TCL_TEST -3 -d -w $(PROJECTCCFLAGS)
-| cfgtest.cfg >NUL
-
-cfgcln:
- -@$(RM) *.cfg
-
-
-# The following rule automatically generates a tcl.def file containing
-# an export entry for every public symbol in the tcl.dll library.
-
-$(TMPDIR)\tcl.def: $(TCLOBJS) $(DUMPEXTS)
- $(DUMPEXTS) -o $(TMPDIR)\tcl.def $(TCLDLL) @&&|
- $(TCLOBJS)
-|
-
-
-# the following two rules are a hack to get around the fact that the
-# 16-bit compiler doesn't handle long file names :-(
-
-$(ROOT)\win\tclWinIn.h: $(ROOT)\win\tclWinInt.h
- $(CP) $(ROOT)\win\tclWinInt.h $(ROOT)\win\tclWinIn.h
-
-$(ROOT)\win\tclWin16.c: $(ROOT)\win\tclWinIn.h
-
-# remove all generated files
-
-clean:
- -@$(RM) *.exe
- -@$(RM) *.lib
- -@$(RM) *.dll
- -@$(RM) $(TMPDIR)\*.res
- -@$(RM) $(TMPDIR)\*.def
- -@$(RM) $(TMPDIR)\*.obj
- -@$(RM) $(TMPDIR)\*.cfg
- -@$(RM) $(ROOT)\win\tclWinIn.h
diff --git a/win/makefile.vc b/win/makefile.vc
index 24f3dd7..25edd12 100644
--- a/win/makefile.vc
+++ b/win/makefile.vc
@@ -2,20 +2,20 @@
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
+#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
-# RCS: @(#) $Id: makefile.vc,v 1.25 1999/03/10 05:52:53 stanton Exp $
+# RCS: @(#) $Id: makefile.vc,v 1.26 1999/04/16 00:48:07 stanton Exp $
# Does not depend on the presence of any environment variables in
-# order to compile tcl; all needed information is derived from
+# order to compile tcl; all needed information is derived from
# location of the compiler directories.
#
# Project directories
#
-# ROOT = top of source tree
+# ROOT = top of source tree
#
# TOOLS32 = location of VC++ 32-bit development tools. Note that the
# VC++ 2.0 header files are broken, so you need to use the
@@ -24,10 +24,10 @@
#
# TOOLS16 = location of VC++ 1.5 16-bit tools, needed to build thunking
# library. This information is optional; if the 16-bit compiler
-# is not available, then the 16-bit code will not be built.
+# is not available, then the 16-bit code will not be built.
# Tcl will still run without the 16-bit code, but...
-# A. Under Windows 3.X you will any calls to the exec command
-# will return an error.
+# 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.
# INSTALLDIR = where the install- targets should copy the binaries and
@@ -39,11 +39,14 @@ TOOLS32 = c:\program files\devstudio\vc
TOOLS32_rc = c:\program files\devstudio\sharedide
TOOLS16 = c:\msvc
-INSTALLDIR = c:\programa files\Tcl
+INSTALLDIR = c:\program files\Tcl
# Set this to the appropriate value of /MACHINE: for your platform
MACHINE = IX86
+# Uncomment the following line to compile with thread support
+#THREADDEFINES = -DTCL_THREADS=1
+
# Set NODEBUG to 0 to compile with symbols
NODEBUG = 1
@@ -53,14 +56,12 @@ NODEBUG = 1
# -DTCL_MEM_DEBUG Enables the debugging memory allocator.
# -DTCL_COMPILE_DEBUG Enables byte compilation logging.
# -DTCL_COMPILE_STATS Enables byte compilation statistics gathering.
-# -DUSE_NATIVE_MALLOC Disables the Tcl memory allocator in favor
+# -DUSE_TCLALLOC=0 Disables the Tcl memory allocator in favor
# of the native malloc implementation. This is
# needed when using Purify.
#
-#DEBUGDEFINES = -DTCL_MEM_DEBUG
-#DEBUGDEFINES = -DTCL_MEM_DEBUG -DTCL_COMPILE_DEBUG
-#DEBUGDEFINES = -DTCL_MEM_DEBUG -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS
-#DEBUGDEFINES = -DUSE_NATIVE_MALLOC
+#DEBUGDEFINES = -DTCL_MEM_DEBUG -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS
+#DEBUGDEFINES = -DUSE_TCLALLOC=0
######################################################################
# Do not modify below this line
@@ -68,8 +69,8 @@ NODEBUG = 1
NAMEPREFIX = tcl
STUBPREFIX = $(NAMEPREFIX)stub
-DOTVERSION = 8.0
-VERSION = 80
+DOTVERSION = 8.1
+VERSION = 81
BINROOT = .
!IF "$(NODEBUG)" == "1"
@@ -100,10 +101,15 @@ TCLPIPEDLLNAME = $(NAMEPREFIX)pip$(VERSION)$(DBGX).dll
TCLPIPEDLL = $(OUTDIR)\$(TCLPIPEDLLNAME)
TCLREGDLLNAME = $(NAMEPREFIX)reg$(VERSION)$(DBGX).dll
TCLREGDLL = $(OUTDIR)\$(TCLREGDLLNAME)
+TCLDDEDLLNAME = $(NAMEPREFIX)dde$(VERSION)$(DBGX).dll
+TCLDDEDLL = $(OUTDIR)\$(TCLDDEDLLNAME)
TCLTEST = $(OUTDIR)\$(NAMEPREFIX)test.exe
DUMPEXTS = $(TMPDIR)\dumpexts.exe
CAT16 = $(TMPDIR)\cat16.exe
CAT32 = $(TMPDIR)\cat32.exe
+RMDIR = .\rmd.bat
+MKDIR = .\mkd.bat
+RM = del
LIB_INSTALL_DIR = $(INSTALLDIR)\lib
BIN_INSTALL_DIR = $(INSTALLDIR)\bin
@@ -117,11 +123,15 @@ TCLTESTOBJS = \
$(TMPDIR)\tclTest.obj \
$(TMPDIR)\tclTestObj.obj \
$(TMPDIR)\tclTestProcBodyObj.obj \
+ $(TMPDIR)\tclThreadTest.obj \
$(TMPDIR)\tclWinTest.obj \
$(TMPDIR)\testMain.obj
TCLOBJS = \
- $(TMPDIR)\regexp.obj \
+ $(TMPDIR)\regcomp.obj \
+ $(TMPDIR)\regexec.obj \
+ $(TMPDIR)\regfree.obj \
+ $(TMPDIR)\regerror.obj \
$(TMPDIR)\strftime.obj \
$(TMPDIR)\tclAlloc.obj \
$(TMPDIR)\tclAsync.obj \
@@ -132,9 +142,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 \
@@ -150,6 +162,7 @@ TCLOBJS = \
$(TMPDIR)\tclIOSock.obj \
$(TMPDIR)\tclIOUtil.obj \
$(TMPDIR)\tclLink.obj \
+ $(TMPDIR)\tclLiteral.obj \
$(TMPDIR)\tclListObj.obj \
$(TMPDIR)\tclLoad.obj \
$(TMPDIR)\tclMain.obj \
@@ -158,19 +171,28 @@ TCLOBJS = \
$(TMPDIR)\tclObj.obj \
$(TMPDIR)\tclPanic.obj \
$(TMPDIR)\tclParse.obj \
+ $(TMPDIR)\tclParseExpr.obj \
$(TMPDIR)\tclPipe.obj \
$(TMPDIR)\tclPkg.obj \
$(TMPDIR)\tclPosixStr.obj \
$(TMPDIR)\tclPreserve.obj \
- $(TMPDIR)\tclResolve.obj \
$(TMPDIR)\tclProc.obj \
+ $(TMPDIR)\tclRegexp.obj \
+ $(TMPDIR)\tclResolve.obj \
+ $(TMPDIR)\tclResult.obj \
+ $(TMPDIR)\tclScan.obj \
$(TMPDIR)\tclStringObj.obj \
$(TMPDIR)\tclStubInit.obj \
+ $(TMPDIR)\tclStubLib.obj \
+ $(TMPDIR)\tclThread.obj \
$(TMPDIR)\tclTimer.obj \
+ $(TMPDIR)\tclUtf.obj \
$(TMPDIR)\tclUtil.obj \
$(TMPDIR)\tclVar.obj \
$(TMPDIR)\tclWin32Dll.obj \
$(TMPDIR)\tclWinChan.obj \
+ $(TMPDIR)\tclWinConsole.obj \
+ $(TMPDIR)\tclWinSerial.obj \
$(TMPDIR)\tclWinError.obj \
$(TMPDIR)\tclWinFCmd.obj \
$(TMPDIR)\tclWinFile.obj \
@@ -180,14 +202,10 @@ TCLOBJS = \
$(TMPDIR)\tclWinNotify.obj \
$(TMPDIR)\tclWinPipe.obj \
$(TMPDIR)\tclWinSock.obj \
- $(TMPDIR)\tclWinTime.obj
+ $(TMPDIR)\tclWinThrd.obj \
+ $(TMPDIR)\tclWinTime.obj
-TCLSTUBOBJS = \
- $(TMPDIR)\tclStubLib.obj \
- $(TMPDIR)\tclStubs.obj \
- $(TMPDIR)\tclPlatStubs.obj \
- $(TMPDIR)\tclIntStubs.obj \
- $(TMPDIR)\tclIntPlatStubs.obj
+TCLSTUBOBJS = $(TMPDIR)\tclStubLib.obj \
cc32 = "$(TOOLS32)\bin\cl.exe"
link32 = "$(TOOLS32)\bin\link.exe"
@@ -200,16 +218,16 @@ link16 = "$(TOOLS16)\bin\link.exe"
rc16 = "$(TOOLS16)\bin\rc.exe"
include16 = -I"$(TOOLS16)\include"
-WINDIR = $(ROOT)\win
+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)
CON_CFLAGS = $(cdebug) $(cflags) $(cvars) $(include32) -DCONSOLE
-DOS_CFLAGS = $(cdebug) $(cflags) $(include16) -AL
+DOS_CFLAGS = $(cdebug) $(cflags) $(include16) -AL
DLL16_CFLAGS = $(cdebug) $(cflags) $(include16) -ALw
######################################################################
@@ -228,9 +246,9 @@ lcommon = /NODEFAULTLIB /RELEASE /NOLOGO
# declarations for use on Intel i386, i486, and Pentium systems
!IF "$(MACHINE)" == "IX86"
DLLENTRY = @12
-lflags = $(lcommon) /MACHINE:$(MACHINE)
+lflags = $(lcommon) /MACHINE:$(MACHINE)
!ELSE
-lflags = $(lcommon) /MACHINE:$(MACHINE)
+lflags = $(lcommon) /MACHINE:$(MACHINE)
!ENDIF
conlflags = $(lflags) -subsystem:console -entry:mainCRTStartup
@@ -246,7 +264,7 @@ libcdll = msvcrt$(DBGX).lib oldnames.lib
!ENDIF
baselibs = kernel32.lib $(optlibs) advapi32.lib user32.lib
-winlibs = $(baselibs) gdi32.lib comdlg32.lib winspool.lib
+winlibs = $(baselibs) gdi32.lib comdlg32.lib winspool.lib
guilibs = $(libc) $(winlibs)
conlibs = $(libc) $(baselibs)
@@ -283,8 +301,8 @@ cflags = $(ccommon) -D_ALPHA_=1
!ENDIF
!ENDIF
-cvars = -DWIN32 -D_WIN32
-cvarsmt = $(cvars) -D_MT
+cvars = -DWIN32 -D_WIN32
+cvarsmt = $(cvars) -D_MT
cvarsdll = $(cvarsmt) -D_DLL
!IF "$(NODEBUG)" == "1"
@@ -298,8 +316,8 @@ cvarsdll = $(cvars) -MDd
######################################################################
release: setup $(TCLSH) dlls
-dlls: setup $(TCL16DLL) $(TCLPIPEDLL) $(TCLREGDLL)
-all: setup $(TCLSH) dlls $(CAT16) $(CAT32)
+dlls: setup $(TCL16DLL) $(TCLPIPEDLL) $(TCLREGDLL) $(TCLDDEDLL)
+all: setup $(TCLSH) dlls $(CAT16) $(CAT32)
tcltest: setup $(TCLTEST) dlls $(CAT16) $(CAT32)
plugin: setup $(TCLPLUGINDLL) $(TCLSHP)
install: install-binaries install-libraries
@@ -308,19 +326,18 @@ test: setup $(TCLTEST) dlls $(CAT16) $(CAT32)
set TCL_LIBRARY=$(ROOT)/library
$(TCLTEST) << "$(TCLREGDLL)"
load [lindex $$argv 0] registry
- cd ../tests
- source all
+ source $(ROOT)/tests/all.tcl
<<
setup:
- @mkd $(TMPDIR)
- @mkd $(OUTDIR)
+ @$(MKDIR) $(TMPDIR)
+ @$(MKDIR) $(OUTDIR)
$(DUMPEXTS): $(WINDIR)\winDumpExts.c
$(cc32) $(CON_CFLAGS) -Fo$(TMPDIR)\ $?
set LIB="$(TOOLS32)\lib"
$(link32) $(ldebug) $(conlflags) $(guilibs) -out:$@ \
- $(TMPDIR)\winDumpExts.obj
+ $(TMPDIR)\winDumpExts.obj
$(TCLLIB): $(TCLDLL)
@@ -346,12 +363,12 @@ $(TCLOBJS)
$(TCLSH): $(TCLSHOBJS) $(TCLLIB) $(TMPDIR)\tclsh.res
set LIB="$(TOOLS32)\lib"
$(link32) $(ldebug) $(conlflags) $(TMPDIR)\tclsh.res -stack:2300000 \
- -out:$@ $(conlibsdll) $(TCLLIB) $(TCLSHOBJS)
+ -out:$@ $(conlibsdll) $(TCLLIB) $(TCLSHOBJS)
$(TCLSHP): $(TCLSHOBJS) $(TCLPLUGINLIB) $(TMPDIR)\tclsh.res
- set LIB="$(TOOLS32)\lib"
+ set LIB=$(TOOLS32)\lib
$(link32) $(ldebug) $(conlflags) $(TMPDIR)\tclsh.res -stack:2300000 \
- -out:$@ $(conlibsdll) $(TCLPLUGINLIB) $(TCLSHOBJS)
+ -out:$@ $(conlibsdll) $(TCLPLUGINLIB) $(TCLSHOBJS)
$(TCLTEST): $(TCLTESTOBJS) $(TCLLIB) $(TMPDIR)\tclsh.res
set LIB="$(TOOLS32)\lib"
@@ -361,17 +378,17 @@ $(TCLTEST): $(TCLTESTOBJS) $(TCLLIB) $(TMPDIR)\tclsh.res
$(TCL16DLL): $(WINDIR)\tcl16.rc $(WINDIR)\tclWin16.c
if exist $(cc16) $(cc16) @<<
$(DLL16_CFLAGS) -Fo$(TMPDIR)\ $(WINDIR)\tclWin16.c
-<<
+<<
@copy << $(TMPDIR)\tclWin16.def > nul
LIBRARY $(@B);dll
EXETYPE WINDOWS
CODE PRELOAD MOVEABLE DISCARDABLE
DATA PRELOAD MOVEABLE SINGLE
-HEAPSIZE 1024
+HEAPSIZE 1024
EXPORTS
WEP @1 RESIDENTNAME
- UTPROC @2
-<<
+ UTPROC @2
+<<
if exist $(cc16) $(link16) /NOLOGO /ONERROR:NOEXE /NOE @<<
$(TMPDIR)\tclWin16.obj
$@
@@ -386,6 +403,11 @@ $(TCLPIPEDLL): $(WINDIR)\stub16.c
set LIB="$(TOOLS32)\lib"
$(link32) $(ldebug) $(conlflags) -out:$@ $(TMPDIR)\stub16.obj $(guilibs)
+$(TCLDDEDLL): $(TMPDIR)\tclWinDde.obj $(TCLSTUBLIB)
+ set LIB="$(TOOLS32)\lib"
+ $(link32) $(ldebug) $(dlllflags) -out:$@ $(TMPDIR)\tclWinDde.obj \
+ $(conlibsdll) $(TCLSTUBLIB)
+
$(TCLREGDLL): $(TMPDIR)\tclWinReg.obj $(TCLSTUBLIB)
set LIB="$(TOOLS32)\lib"
$(link32) $(ldebug) $(dlllflags) -out:$@ $(TMPDIR)\tclWinReg.obj \
@@ -398,7 +420,7 @@ $(CAT32): $(WINDIR)\cat.c
$(CAT16): $(WINDIR)\cat.c
if exist $(cc16) $(cc16) $(DOS_CFLAGS) -Fo$(TMPDIR)\ $?
- set LIB="$(TOOLS16)\lib"
+ set LIB=$(TOOLS16)\lib
if exist $(cc16) $(link16) /NOLOGO /ONERROR:NOEXE /NOI /STACK:16384 \
$(TMPDIR)\cat.obj,$@,nul,llibce.lib,nul
@@ -413,44 +435,49 @@ $(TCLOBJS)
<<
install-binaries: $(TCLSH)
- @mkd $(BIN_INSTALL_DIR)
- @mkd $(LIB_INSTALL_DIR)
+ $(MKDIR) "$(BIN_INSTALL_DIR)"
+ $(MKDIR) "$(LIB_INSTALL_DIR)"
@echo installing $(TCLDLLNAME)
- @copy $(TCLDLL) $(BIN_INSTALL_DIR)
- @copy $(TCLLIB) $(LIB_INSTALL_DIR)
- @echo installing $(TCLSH)
- @copy $(TCLSH) $(BIN_INSTALL_DIR)
+ @copy "$(TCLDLL)" "$(BIN_INSTALL_DIR)"
+ @copy "$(TCLLIB)" "$(LIB_INSTALL_DIR)"
+ @echo installing "$(TCLSH)"
+ @copy "$(TCLSH)" "$(BIN_INSTALL_DIR)"
@echo installing $(TCLPIPEDLLNAME)
- @copy $(TCLPIPEDLL) $(BIN_INSTALL_DIR)
+ @copy "$(TCLPIPEDLL)" "$(BIN_INSTALL_DIR)"
@echo installing $(TCLREGDLLNAME)
- @copy $(TCLREGDLL) $(LIB_INSTALL_DIR)
- echo installing $(TCLSTUBLIBNAME)
- copy $(TCLSTUBLIB) $(LIB_INSTALL_DIR)
+ @copy "$(TCLREGDLL)" "$(LIB_INSTALL_DIR)"
+ @echo installing $(TCLDDEDLLNAME)
+ @copy "$(TCLDDEDLL)" "$(LIB_INSTALL_DIR)"
+ @echo installing $(TCLSTUBLIBNAME)
+ @copy "$(TCLSTUBLIB)" "$(LIB_INSTALL_DIR)"
install-libraries:
- -@mkd $(LIB_INSTALL_DIR)
- -@mkd $(INCLUDE_INSTALL_DIR)
- -@mkd $(SCRIPT_INSTALL_DIR)
- -@mkd $(SCRIPT_INSTALL_DIR)\http1.0
+ -@$(MKDIR) "$(LIB_INSTALL_DIR)"
+ -@$(MKDIR) "$(INCLUDE_INSTALL_DIR)"
+ -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)"
+ -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http1.0"
@copy << "$(SCRIPT_INSTALL_DIR)\pkgIndex.tcl"
package ifneeded registry 1.0 "load [list [file join $$dir .. $(TCLREGDLLNAME)]] registry"
+package ifneeded dde 1.0 "load [list [file join $$dir .. $(TCLDDEDLLNAME)]] dde"
<<
- -@copy $(ROOT)\library\http1.0\http.tcl $(SCRIPT_INSTALL_DIR)\http1.0
- -@copy $(ROOT)\library\http1.0\pkgIndex.tcl $(SCRIPT_INSTALL_DIR)\http1.0
- -@mkd $(SCRIPT_INSTALL_DIR)\http2.0
- -@copy $(ROOT)\library\http2.0\http.tcl $(SCRIPT_INSTALL_DIR)\http2.0
- -@copy $(ROOT)\library\http2.0\pkgIndex.tcl $(SCRIPT_INSTALL_DIR)\http2.0
- -@mkd $(SCRIPT_INSTALL_DIR)\opt0.1
- -@copy $(ROOT)\library\opt0.1\optparse.tcl $(SCRIPT_INSTALL_DIR)\opt0.1
- -@copy $(ROOT)\library\opt0.1\pkgIndex.tcl $(SCRIPT_INSTALL_DIR)\opt0.1
- -@copy $(GENERICDIR)\tcl.h $(INCLUDE_INSTALL_DIR)
- -@copy $(ROOT)\library\history.tcl $(SCRIPT_INSTALL_DIR)
- -@copy $(ROOT)\library\init.tcl $(SCRIPT_INSTALL_DIR)
- -@copy $(ROOT)\library\ldAout.tcl $(SCRIPT_INSTALL_DIR)
- -@copy $(ROOT)\library\parray.tcl $(SCRIPT_INSTALL_DIR)
- -@copy $(ROOT)\library\safe.tcl $(SCRIPT_INSTALL_DIR)
- -@copy $(ROOT)\library\tclIndex $(SCRIPT_INSTALL_DIR)
- -@copy $(ROOT)\library\word.tcl $(SCRIPT_INSTALL_DIR)
+ -@copy "$(ROOT)\library\http1.0\http.tcl" "$(SCRIPT_INSTALL_DIR)\http1.0"
+ -@copy "$(ROOT)\library\http1.0\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http1.0"
+ -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\http2.0"
+ -@copy "$(ROOT)\library\http2.0\http.tcl" "$(SCRIPT_INSTALL_DIR)\http2.0"
+ -@copy "$(ROOT)\library\http2.0\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\http2.0"
+ -@$(MKDIR) "$(SCRIPT_INSTALL_DIR)\opt0.4"
+ -@copy "$(ROOT)\library\opt0.4\optparse.tcl" "$(SCRIPT_INSTALL_DIR)\opt0.4"
+ -@copy "$(ROOT)\library\opt0.4\pkgIndex.tcl" "$(SCRIPT_INSTALL_DIR)\opt0.4"
+ -@copy "$(GENERICDIR)\tcl.h" "$(INCLUDE_INSTALL_DIR)"
+ -@copy "$(ROOT)\library\history.tcl" "$(SCRIPT_INSTALL_DIR)"
+ -@copy "$(ROOT)\library\init.tcl" "$(SCRIPT_INSTALL_DIR)"
+ -@copy "$(ROOT)\library\ldAout.tcl" "$(SCRIPT_INSTALL_DIR)"
+ -@copy "$(ROOT)\library\parray.tcl" "$(SCRIPT_INSTALL_DIR)"
+ -@copy "$(ROOT)\library\safe.tcl" "$(SCRIPT_INSTALL_DIR)"
+ -@copy "$(ROOT)\library\tclIndex" "$(SCRIPT_INSTALL_DIR)"
+ -@copy "$(ROOT)\library\package.tcl" "$(SCRIPT_INSTALL_DIR)"
+ -@copy "$(ROOT)\library\word.tcl" "$(SCRIPT_INSTALL_DIR)"
+ -@copy "$(ROOT)\library\auto.tcl" "$(SCRIPT_INSTALL_DIR)"
#
# Regenerate the stubs files.
@@ -487,18 +514,37 @@ $(TMPDIR)\tclAppInit.obj : $(WINDIR)\tclAppInit.c
$(TMPDIR)\tclWinReg.obj : $(WINDIR)\tclWinReg.c
$(cc32) $(TCL_CFLAGS) -DUSE_TCL_STUBS -Fo$@ $?
+$(TMPDIR)\tclWinDde.obj : $(WINDIR)\tclWinDde.c
+ $(cc32) $(TCL_CFLAGS) -DUSE_TCL_STUBS -Fo$@ $?
+
# The following objects are part of the stub library and should not
# be built as DLL objects but none of the symbols should be exported
-$(TMPDIR)\tclStubs.obj : $(GENERICDIR)\tclStubs.c
- $(cc32) $(TCL_CFLAGS) -DSTATIC_BUILD -Fo$@ $?
-$(TMPDIR)\tclPlatStubs.obj : $(GENERICDIR)\tclPlatStubs.c
- $(cc32) $(TCL_CFLAGS) -DSTATIC_BUILD -Fo$@ $?
-$(TMPDIR)\tclIntStubs.obj : $(GENERICDIR)\tclIntStubs.c
- $(cc32) $(TCL_CFLAGS) -DSTATIC_BUILD -Fo$@ $?
-$(TMPDIR)\tclPlatIntStubs.obj : $(GENERICDIR)\tclPlatIntStubs.c
+$(TMPDIR)\tclStubLib.obj : $(GENERICDIR)\tclStubLib.c
$(cc32) $(TCL_CFLAGS) -DSTATIC_BUILD -Fo$@ $?
+
+# Dedependency rules
+
+$(GENERICDIR)\regcomp.c: \
+ $(GENERICDIR)\regguts.h \
+ $(GENERICDIR)\regc_lex.c \
+ $(GENERICDIR)\regc_color.c \
+ $(GENERICDIR)\regc_nfa.c \
+ $(GENERICDIR)\regc_cvec.c \
+ $(GENERICDIR)\regc_locale.c
+$(GENERICDIR)\regcustom.h: \
+ $(GENERICDIR)\tclInt.h \
+ $(GENERICDIR)\tclPort.h \
+ $(GENERICDIR)\regex.h
+$(GENERICDIR)\regexec.c: \
+ $(GENERICDIR)\rege_dfa.c \
+ $(GENERICDIR)\regguts.h
+$(GENERICDIR)\regerror.c: $(GENERICDIR)\regguts.h
+$(GENERICDIR)\regfree.c: $(GENERICDIR)\regguts.h
+$(GENERICDIR)\regfronts.c: $(GENERICDIR)\regguts.h
+$(GENERICDIR)\regguts.h: $(GENERICDIR)\regcustom.h
+
#
# Implicit rules
#
@@ -517,15 +563,15 @@ $(TMPDIR)\tclPlatIntStubs.obj : $(GENERICDIR)\tclPlatIntStubs.c
$(TCL_DEFINES) $<
clean:
- -@del $(OUTDIR)\*.exp
- -@del $(OUTDIR)\*.lib
- -@del $(OUTDIR)\*.dll
- -@del $(OUTDIR)\*.exe
- -@del $(OUTDIR)\*.pdb
- -@del $(TMPDIR)\*.pch
- -@del $(TMPDIR)\*.obj
- -@del $(TMPDIR)\*.res
- -@del $(TMPDIR)\*.def
- -@del $(TMPDIR)\*.exe
- -@rmd $(OUTDIR)
- -@rmd $(TMPDIR)
+ -@$(RM) $(OUTDIR)\*.exp
+ -@$(RM) $(OUTDIR)\*.lib
+ -@$(RM) $(OUTDIR)\*.dll
+ -@$(RM) $(OUTDIR)\*.exe
+ -@$(RM) $(OUTDIR)\*.pdb
+ -@$(RM) $(TMPDIR)\*.pch
+ -@$(RM) $(TMPDIR)\*.obj
+ -@$(RM) $(TMPDIR)\*.res
+ -@$(RM) $(TMPDIR)\*.def
+ -@$(RM) $(TMPDIR)\*.exe
+ -@$(RMDIR) $(OUTDIR)
+ -@$(RMDIR) $(TMPDIR)
diff --git a/win/pkgIndex.tcl b/win/pkgIndex.tcl
index 3a9465c..6c7570a 100644
--- a/win/pkgIndex.tcl
+++ b/win/pkgIndex.tcl
@@ -6,6 +6,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: pkgIndex.tcl,v 1.2 1998/09/14 18:40:19 stanton Exp $
+# RCS: @(#) $Id: pkgIndex.tcl,v 1.3 1999/04/16 00:48:07 stanton Exp $
-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}}]
+package ifneeded dde 1.0 [list tclPkgSetup $dir dde 1.0 {{tcldde81.dll load dde}}]
diff --git a/win/tcl.rc b/win/tcl.rc
index f6dab40..49f9316 100644
--- a/win/tcl.rc
+++ b/win/tcl.rc
@@ -1,4 +1,4 @@
-// RCS: @(#) $Id: tcl.rc,v 1.2 1998/09/14 18:40:19 stanton Exp $
+// RCS: @(#) $Id: tcl.rc,v 1.3 1999/04/16 00:48:07 stanton Exp $
//
// 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 a782a54..d157656 100644
--- a/win/tclAppInit.c
+++ b/win/tclAppInit.c
@@ -5,12 +5,13 @@
* 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.
+ * Copyright (c) 1998-1999 by Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclAppInit.c,v 1.4 1999/02/03 02:58:26 stanton Exp $
+ * RCS: @(#) $Id: tclAppInit.c,v 1.5 1999/04/16 00:48:07 stanton Exp $
*/
#include "tcl.h"
@@ -22,6 +23,9 @@ extern int Procbodytest_Init _ANSI_ARGS_((Tcl_Interp *interp));
extern int Procbodytest_SafeInit _ANSI_ARGS_((Tcl_Interp *interp));
extern int Tcltest_Init _ANSI_ARGS_((Tcl_Interp *interp));
extern int TclObjTest_Init _ANSI_ARGS_((Tcl_Interp *interp));
+#ifdef TCL_THREADS
+extern int TclThread_Init _ANSI_ARGS_((Tcl_Interp *interp));
+#endif
#endif /* TCL_TEST */
static void setargv _ANSI_ARGS_((int *argcPtr, char ***argvPtr));
@@ -49,31 +53,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. */
}
@@ -90,7 +77,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.
@@ -115,6 +102,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
if (Procbodytest_Init(interp) == TCL_ERROR) {
return TCL_ERROR;
}
@@ -185,7 +177,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
@@ -194,9 +186,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') {
@@ -204,8 +196,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--;
@@ -213,7 +205,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') {
@@ -247,7 +239,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 16c47c1..5a90b77 100644
--- a/win/tclWin32Dll.c
+++ b/win/tclWin32Dll.c
@@ -1,4 +1,5 @@
/*
+
* tclWin32Dll.c --
*
* This file contains the DLL entry point which sets up the 32-to-16-bit
@@ -9,50 +10,124 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclWin32Dll.c,v 1.5 1999/03/10 05:52:53 stanton Exp $
+ * RCS: @(#) $Id: tclWin32Dll.c,v 1.6 1999/04/16 00:48:07 stanton Exp $
*/
#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.
*/
-BOOL APIENTRY DllMain _ANSI_ARGS_((HINSTANCE hInst,
- DWORD reason, LPVOID reserved));
+BOOL APIENTRY DllMain(HINSTANCE hInst, DWORD reason,
+ LPVOID reserved);
+
#ifdef __WIN32__
#ifndef STATIC_BUILD
@@ -110,18 +185,24 @@ DllMain(hInst, reason, reserved)
{
switch (reason) {
case DLL_PROCESS_ATTACH:
- if (tclProcessesAttached++) {
- return FALSE; /* Not the first initialization. */
+ 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.
+ */
+
+ return FALSE;
}
TclWinInit(hInst);
return TRUE;
case DLL_PROCESS_DETACH:
-
- tclProcessesAttached--;
- if (tclProcessesAttached == 0) {
- Tcl_Finalize();
+ if (hInst == hInstance) {
+ Tcl_Finalize();
}
break;
}
@@ -135,244 +216,206 @@ DllMain(hInst, reason, reserved)
/*
*----------------------------------------------------------------------
*
- * TclWinInit --
+ * TclWinSynchSpawn --
*
- * This function initializes the internal state of the tcl library.
+ * 32-bit entry point to the 16-bit SynchSpawn code.
*
* Results:
- * None.
+ * 1 on success, 0 on failure.
*
* Side effects:
- * Initializes the 16-bit thunking library, and the tclPlatformId
- * variable.
+ * Spawns a command and waits for it to complete.
*
*----------------------------------------------------------------------
*/
-
-void
-TclWinInit(hInst)
- HINSTANCE hInst; /* Library instance handle. */
+int
+TclWinSynchSpawn(void *args, int type, void **trans, Tcl_Pid *pidPtr)
{
- OSVERSIONINFO os;
-
- tclInstance = hInst;
- os.dwOSVersionInfoSize = sizeof(os);
- GetVersionEx(&os);
- tclPlatformId = os.dwPlatformId;
+ HINSTANCE hKernel;
+ UTREGISTER *utRegisterProc;
+ UTUNREGISTER *utUnRegisterProc;
+ UT32PROC *ut32Proc;
+ char buffer[] = "TCL16xx.DLL";
+ int result;
+
+ hKernel = LoadLibraryA("kernel32.dll");
+ if (hKernel == NULL) {
+ return 0;
+ }
/*
- * 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.
+ * Load the Universal Thunking routines from kernel32.dll.
*/
- if (tclPlatformId == VER_PLATFORM_WIN32s) {
- SetErrorMode(SetErrorMode(0) | SEM_FAILCRITICALERRORS);
+ utRegisterProc = (UTREGISTER *) GetProcAddress(hKernel, "UTRegister");
+ utUnRegisterProc = (UTUNREGISTER *) GetProcAddress(hKernel, "UTUnRegister");
+ if ((utRegisterProc == NULL) || (utUnRegisterProc == NULL)) {
+ result = 0;
+ goto done;
}
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclpFinalize --
- *
- * Clean up the Windows specific library state.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Unloads any DLLs and cleans up the thunking library, if
- * necessary.
- *
- *----------------------------------------------------------------------
- */
-void
-TclpFinalize()
-{
/*
- * Unregister the Tcl thunk.
+ * Construct the complete name of tcl16xx.dll.
*/
- if (UTUnRegister != NULL) {
- UTUnRegister(tclInstance);
- UTUnRegister = NULL;
- }
+ buffer[5] = '0' + TCL_MAJOR_VERSION;
+ buffer[6] = '0' + TCL_MINOR_VERSION;
/*
- * Cleanup any dynamically loaded libraries.
+ * Register the Tcl thunk.
*/
- UnloadLibraries();
+ if ((*utRegisterProc)(hInstance, buffer, NULL, "UTProc", &ut32Proc,
+ NULL, NULL) == FALSE) {
+ result = 0;
+ goto done;
+ }
+ if (ut32Proc != NULL) {
+ /*
+ * Invoke the thunk.
+ */
+
+ *pidPtr = 0;
+ (*ut32Proc)(args, type, trans);
+ result = 1;
+ } else {
+ /*
+ * The 16-bit thunking DLL wasn't found. Return error code that
+ * indicates this problem.
+ */
+
+ result = 0;
+ }
+ (*utUnRegisterProc)(hInstance);
+
+ done:
+ FreeLibrary(hKernel);
+ return result;
}
/*
*----------------------------------------------------------------------
*
- * TclWinLoadLibrary --
+ * TclWinGetTclInstance --
*
- * 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.
+ * Retrieves the global library instance handle.
*
* Results:
- * Returns the handle of the newly loaded library, or NULL on
- * failure.
+ * Returns the global library instance handle.
*
* Side effects:
- * Loads the specified library into the process.
+ * None.
*
*----------------------------------------------------------------------
*/
HINSTANCE
-TclWinLoadLibrary(name)
- char *name; /* Library file to load. */
+TclWinGetTclInstance()
{
- 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;
+ return hInstance;
}
/*
*----------------------------------------------------------------------
*
- * UnloadLibraries --
+ * TclWinInit --
*
- * Frees any dynamically allocated libraries loaded by Tcl.
+ * This function initializes the internal state of the tcl library.
*
* Results:
* None.
*
* Side effects:
- * Frees the libraries on the library list as well as the list.
+ * Initializes the 16-bit thunking library, and the tclPlatformId
+ * variable.
*
*----------------------------------------------------------------------
*/
-static void
-UnloadLibraries()
+void
+TclWinInit(hInst)
+ HINSTANCE hInst; /* Library instance handle. */
{
- LibraryList *ptr;
+ OSVERSIONINFO os;
+
+ hInstance = hInst;
+ os.dwOSVersionInfoSize = sizeof(os);
+ GetVersionEx(&os);
+ platformId = os.dwPlatformId;
- while (libraryList != NULL) {
- FreeLibrary(libraryList->handle);
- ptr = libraryList->nextPtr;
- ckfree((char*)libraryList);
- libraryList = ptr;
+ /*
+ * 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 (platformId == VER_PLATFORM_WIN32s) {
+ SetErrorMode(SetErrorMode(0) | SEM_FAILCRITICALERRORS);
}
+
+ tclWinProcs = &asciiProcs;
}
/*
*----------------------------------------------------------------------
*
- * TclWinSynchSpawn --
+ * TclWinGetPlatformId --
*
- * 32-bit entry point to the 16-bit SynchSpawn code.
+ * Determines whether running under NT, 95, or Win32s, to allow
+ * runtime conditional code.
*
* Results:
- * 1 on success, 0 on failure.
+ * The return value is one of:
+ * VER_PLATFORM_WIN32s Win32s on Windows 3.1.
+ * VER_PLATFORM_WIN32_WINDOWS Win32 on Windows 95.
+ * VER_PLATFORM_WIN32_NT Win32 on Windows NT
*
* Side effects:
- * Spawns a command and waits for it to complete.
+ * None.
*
*----------------------------------------------------------------------
*/
-int
-TclWinSynchSpawn(void *args, int type, void **trans, Tcl_Pid *pidPtr)
-{
- static UT32PROC UTProc = NULL;
- static int utErrorCode;
-
- if (UTUnRegister == NULL) {
- /*
- * Load the Universal Thunking routines from kernel32.dll.
- */
-
- HINSTANCE hKernel;
- PUTREGISTER UTRegister;
- char buffer[] = "TCL16xx.DLL";
-
- hKernel = TclWinLoadLibrary("Kernel32.Dll");
- if (hKernel == NULL) {
- return 0;
- }
-
- UTRegister = (PUTREGISTER) GetProcAddress(hKernel, "UTRegister");
- UTUnRegister = (PUTUNREGISTER) GetProcAddress(hKernel, "UTUnRegister");
- if (!UTRegister || !UTUnRegister) {
- UnloadLibraries();
- return 0;
- }
-
- /*
- * Construct the complete name of tcl16xx.dll.
- */
- buffer[5] = '0' + TCL_MAJOR_VERSION;
- buffer[6] = '0' + TCL_MINOR_VERSION;
-
- /*
- * Register the Tcl thunk.
- */
-
- if (UTRegister(tclInstance, buffer, NULL, "UTProc", &UTProc, NULL,
- NULL) == FALSE) {
- utErrorCode = GetLastError();
- }
- }
-
- if (UTProc == NULL) {
- /*
- * The 16-bit thunking DLL wasn't found. Return error code that
- * indicates this problem.
- */
-
- SetLastError(utErrorCode);
- return 0;
- }
-
- UTProc(args, type, trans);
- *pidPtr = 0;
- return 1;
+int
+TclWinGetPlatformId()
+{
+ return platformId;
}
/*
- *----------------------------------------------------------------------
+ *-------------------------------------------------------------------------
*
- * TclWinGetTclInstance --
+ * TclWinNoBackslash --
*
- * Retrieves the global library instance handle.
+ * We're always iterating through a string in Windows, changing the
+ * backslashes to slashes for use in Tcl.
*
* Results:
- * Returns the global library instance handle.
+ * All backslashes in given string are changed to slashes.
*
* Side effects:
* None.
*
- *----------------------------------------------------------------------
+ *-------------------------------------------------------------------------
*/
-HINSTANCE
-TclWinGetTclInstance()
+char *
+TclWinNoBackslash(
+ char *path) /* String to change. */
{
- return tclInstance;
+ char *p;
+
+ for (p = path; *p != '\0'; p++) {
+ if (*p == '\\') {
+ *p = '/';
+ }
+ }
+ return path;
}
/*
@@ -409,20 +452,18 @@ TclpCheckStackSpace()
return 0;
}
+
/*
*----------------------------------------------------------------------
*
- * TclWinGetPlatformId --
+ * TclWinGetPlatform --
*
- * Determines whether running under NT, 95, or Win32s, to allow
- * runtime conditional code.
+ * This is a kludge that allows the test library to get access
+ * the internal tclPlatform variable.
*
* Results:
- * The return value is one of:
- * VER_PLATFORM_WIN32s Win32s on Windows 3.1.
- * VER_PLATFORM_WIN32_WINDOWS Win32 on Windows 95.
- * VER_PLATFORM_WIN32_NT Win32 on Windows NT
+ * Returns a pointer to the tclPlatform variable.
*
* Side effects:
* None.
@@ -430,8 +471,122 @@ TclpCheckStackSpace()
*----------------------------------------------------------------------
*/
-int
-TclWinGetPlatformId()
+TclPlatformType *
+TclWinGetPlatform()
+{
+ return &tclPlatform;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclWinSetInterfaces --
+ *
+ * A helper proc that allows the test library to change the
+ * tclWinProcs structure to dispatch to either the wide-character
+ * or multi-byte versions of the operating system calls, depending
+ * on whether Unicode is the system encoding.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+void
+TclWinSetInterfaces(
+ int wide) /* Non-zero to use wide interfaces, 0
+ * otherwise. */
+{
+ Tcl_FreeEncoding(tclWinTCharEncoding);
+
+ if (wide) {
+ tclWinProcs = &unicodeProcs;
+ tclWinTCharEncoding = Tcl_GetEncoding(NULL, "unicode");
+ } else {
+ tclWinProcs = &asciiProcs;
+ tclWinTCharEncoding = NULL;
+ }
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Tcl_WinUtfToTChar, Tcl_WinTCharToUtf --
+ *
+ * Convert between UTF-8 and Unicode when running Windows NT or
+ * the current ANSI code page when running Windows 95.
+ *
+ * On Mac, Unix, and Windows 95, all strings exchanged between Tcl
+ * and the OS are "char" oriented. We need only one Tcl_Encoding to
+ * convert between UTF-8 and the system's native encoding. We use
+ * NULL to represent that encoding.
+ *
+ * On NT, some strings exchanged between Tcl and the OS are "char"
+ * oriented, while others are in Unicode. We need two Tcl_Encoding
+ * APIs depending on whether we are targeting a "char" or Unicode
+ * interface.
+ *
+ * Calling Tcl_UtfToExternal() or Tcl_ExternalToUtf() with an
+ * encoding of NULL should always used to convert between UTF-8
+ * and the system's "char" oriented encoding. The following two
+ * functions are used in Windows-specific code to convert between
+ * UTF-8 and Unicode strings (NT) or "char" strings(95). This saves
+ * you the trouble of writing the following type of fragment over and
+ * over:
+ *
+ * if (running NT) {
+ * encoding <- Tcl_GetEncoding("unicode");
+ * nativeBuffer <- UtfToExternal(encoding, utfBuffer);
+ * Tcl_FreeEncoding(encoding);
+ * } else {
+ * nativeBuffer <- UtfToExternal(NULL, utfBuffer);
+ * }
+ *
+ * By convention, in Windows a TCHAR is a character in the ANSI code
+ * page on Windows 95, a Unicode character on Windows NT. If you
+ * plan on targeting a Unicode interfaces when running on NT and a
+ * "char" oriented interface while running on 95, these functions
+ * should be used. If you plan on targetting the same "char"
+ * oriented function on both 95 and NT, use Tcl_UtfToExternal()
+ * with an encoding of NULL.
+ *
+ * Results:
+ * The result is a pointer to the string in the desired target
+ * encoding. Storage for the result string is allocated in
+ * dsPtr; the caller must call Tcl_DStringFree() when the result
+ * is no longer needed.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+TCHAR *
+Tcl_WinUtfToTChar(string, len, dsPtr)
+ CONST char *string; /* Source string in UTF-8. */
+ int len; /* Source string length in bytes, or < 0 for
+ * strlen(). */
+ Tcl_DString *dsPtr; /* Uninitialized or free DString in which
+ * the converted string is stored. */
+{
+ return (TCHAR *) Tcl_UtfToExternalDString(tclWinTCharEncoding,
+ string, len, dsPtr);
+}
+
+char *
+Tcl_WinTCharToUtf(string, len, dsPtr)
+ CONST TCHAR *string; /* Source string in Unicode when running
+ * NT, ANSI when running 95. */
+ int len; /* Source string length in bytes, or < 0 for
+ * platform-specific string length. */
+ Tcl_DString *dsPtr; /* Uninitialized or free DString in which
+ * the converted string is stored. */
{
- return tclPlatformId;
+ return Tcl_ExternalToUtfDString(tclWinTCharEncoding,
+ (CONST char *) string, len, dsPtr);
}
diff --git a/win/tclWinChan.c b/win/tclWinChan.c
index c2ba568..e2126fb 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.
*
- * RCS: @(#) $Id: tclWinChan.c,v 1.5 1999/03/10 05:52:53 stanton Exp $
+ * RCS: @(#) $Id: tclWinChan.c,v 1.6 1999/04/16 00:48:07 stanton Exp $
*/
#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.
*/
@@ -36,6 +22,9 @@ static int initialized = 0;
#define FILE_ASYNC (1<<1) /* Channel is non-blocking. */
#define FILE_APPEND (1<<2) /* File is in append mode. */
+#define FILE_TYPE_SERIAL (FILE_TYPE_PIPE+1)
+#define FILE_TYPE_CONSOLE (FILE_TYPE_PIPE+2)
+
/*
* The following structure contains per-instance data for a file based channel.
*/
@@ -53,11 +42,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.
+ */
+
+ FileInfo *firstFilePtr;
+} ThreadSpecificData;
-static FileInfo *firstFilePtr;
+static Tcl_ThreadDataKey dataKey;
/*
* The following structure is what is added to the Tcl event queue when
@@ -77,14 +70,6 @@ typedef struct FileEvent {
* Static routines for this file:
*/
-static int ComGetOptionProc _ANSI_ARGS_((ClientData instanceData,
- Tcl_Interp *interp, char *optionName,
- Tcl_DString *dsPtr));
-static int ComInputProc _ANSI_ARGS_((ClientData instanceData,
- char *buf, int toRead, int *errorCode));
-static int ComSetOptionProc _ANSI_ARGS_((ClientData instanceData,
- Tcl_Interp *interp, char *optionName,
- char *value));
static int FileBlockProc _ANSI_ARGS_((ClientData instanceData,
int mode));
static void FileChannelExitHandler _ANSI_ARGS_((
@@ -97,7 +82,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,
@@ -127,18 +112,6 @@ static Tcl_ChannelType fileChannelType = {
FileGetHandleProc, /* Get an OS handle from channel. */
};
-static Tcl_ChannelType comChannelType = {
- "com", /* Type name. */
- FileBlockProc, /* Set blocking or non-blocking mode.*/
- FileCloseProc, /* Close proc. */
- ComInputProc, /* Input proc. */
- FileOutputProc, /* Output proc. */
- NULL, /* Seek proc. */
- ComSetOptionProc, /* Set option proc. */
- ComGetOptionProc, /* Get option proc. */
- FileWatchProc, /* Set up notifier to watch the channel. */
- FileGetHandleProc /* Get an OS handle from channel. */
-};
/*
*----------------------------------------------------------------------
@@ -156,13 +129,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 +165,6 @@ FileChannelExitHandler(clientData)
ClientData clientData; /* Old window proc */
{
Tcl_DeleteEventSource(FileSetupProc, FileCheckProc, NULL);
- initialized = 0;
}
/*
@@ -214,6 +191,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 +201,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 +234,7 @@ FileCheckProc(data, flags)
{
FileEvent *evPtr;
FileInfo *infoPtr;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!(flags & TCL_FILE_EVENTS)) {
return;
@@ -266,7 +246,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 +286,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 +299,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 +373,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 +381,22 @@ FileCloseProc(instanceData, interp)
FileWatchProc(instanceData, 0);
- if (CloseHandle(fileInfoPtr->handle) == FALSE) {
- TclWinConvertError(GetLastError());
- errorCode = errno;
+ /*
+ * Don't close the Win32 handle if the handle is a standard channel
+ * during the exit process. Otherwise, one thread may kill the stdio
+ * of another.
+ */
+
+ if (!TclInExit()
+ || ((GetStdHandle(STD_INPUT_HANDLE) != fileInfoPtr->handle)
+ && (GetStdHandle(STD_OUTPUT_HANDLE) != fileInfoPtr->handle)
+ && (GetStdHandle(STD_ERROR_HANDLE) != fileInfoPtr->handle))) {
+ if (CloseHandle(fileInfoPtr->handle) == FALSE) {
+ TclWinConvertError(GetLastError());
+ errorCode = errno;
+ }
}
- for (nextPtrPtr = &firstFilePtr; (*nextPtrPtr) != NULL;
+ for (nextPtrPtr = &(tsdPtr->firstFilePtr); (*nextPtrPtr) != NULL;
nextPtrPtr = &((*nextPtrPtr)->nextPtr)) {
if ((*nextPtrPtr) == fileInfoPtr) {
(*nextPtrPtr) = fileInfoPtr->nextPtr;
@@ -455,7 +450,7 @@ FileSeekProc(instanceData, offset, mode, errorCodePtr)
if (newPos == 0xFFFFFFFF) {
TclWinConvertError(GetLastError());
*errorCodePtr = errno;
- return -1;
+ return -1;
}
return newPos;
}
@@ -605,7 +600,7 @@ FileWatchProc(instanceData, mask)
*
* FileGetHandleProc --
*
- * Called from Tcl_GetChannelFile to retrieve OS handles from
+ * Called from Tcl_GetChannelHandle to retrieve OS handles from
* a file based channel.
*
* Results:
@@ -633,196 +628,7 @@ FileGetHandleProc(instanceData, direction, handlePtr)
return TCL_ERROR;
}
}
-
-/*
- *----------------------------------------------------------------------
- *
- * ComInputProc --
- *
- * Reads input from the IO channel into the buffer given. Returns
- * count of how many bytes were actually read, and an error indication.
- *
- * Results:
- * A count of how many bytes were read is returned and an error
- * indication is returned in an output argument.
- *
- * Side effects:
- * Reads input from the actual channel.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-ComInputProc(instanceData, buf, bufSize, errorCode)
- ClientData instanceData; /* File state. */
- char *buf; /* Where to store data read. */
- int bufSize; /* How much space is available
- * in the buffer? */
- int *errorCode; /* Where to store error code. */
-{
- FileInfo *infoPtr;
- DWORD bytesRead;
- DWORD dw;
- COMSTAT cs;
-
- *errorCode = 0;
- infoPtr = (FileInfo *) instanceData;
-
- if (ClearCommError(infoPtr->handle, &dw, &cs)) {
- if (dw != 0) {
- *errorCode = EIO;
- return -1;
- }
- if (cs.cbInQue != 0) {
- if ((DWORD) bufSize > cs.cbInQue) {
- bufSize = cs.cbInQue;
- }
- } else {
- if (infoPtr->flags & FILE_ASYNC) {
- errno = *errorCode = EAGAIN;
- return -1;
- } else {
- bufSize = 1;
- }
- }
- }
-
- if (ReadFile(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize, &bytesRead,
- (LPOVERLAPPED) NULL) == FALSE) {
- TclWinConvertError(GetLastError());
- *errorCode = errno;
- return -1;
- }
-
- return bytesRead;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * ComSetOptionProc --
- *
- * Sets an option on a channel.
- *
- * Results:
- * A standard Tcl result. Also sets interp->result on error if
- * interp is not NULL.
- *
- * Side effects:
- * May modify an option on a device.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-ComSetOptionProc(instanceData, interp, optionName, value)
- ClientData instanceData; /* File state. */
- Tcl_Interp *interp; /* For error reporting - can be NULL. */
- char *optionName; /* Which option to set? */
- char *value; /* New value for option. */
-{
- FileInfo *infoPtr;
- DCB dcb;
- int len;
- infoPtr = (FileInfo *) instanceData;
-
- len = strlen(optionName);
- if ((len > 1) && (strncmp(optionName, "-mode", len) == 0)) {
- if (GetCommState(infoPtr->handle, &dcb)) {
- if ((BuildCommDCB(value, &dcb) == FALSE) ||
- (SetCommState(infoPtr->handle, &dcb) == FALSE)) {
- /*
- * one should separate the 2 errors...
- */
- if (interp) {
- Tcl_AppendResult(interp, "bad value for -mode: should be ",
- "baud,parity,data,stop", NULL);
- }
- return TCL_ERROR;
- } else {
- return TCL_OK;
- }
- } else {
- if (interp) {
- Tcl_AppendResult(interp, "can't get comm state", NULL);
- }
- return TCL_ERROR;
- }
- } else {
- return Tcl_BadChannelOption(interp, optionName, "mode");
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * ComGetOptionProc --
- *
- * Gets a mode associated with an IO channel. If the optionName arg
- * is non NULL, retrieves the value of that option. If the optionName
- * arg is NULL, retrieves a list of alternating option names and
- * values for the given channel.
- *
- * Results:
- * A standard Tcl result. Also sets the supplied DString to the
- * string value of the option(s) returned.
- *
- * Side effects:
- * The string returned by this function is in static storage and
- * may be reused at any time subsequent to the call.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-ComGetOptionProc(instanceData, interp, optionName, dsPtr)
- ClientData instanceData; /* File state. */
- Tcl_Interp *interp; /* For error reporting - can be NULL. */
- char *optionName; /* Option to get. */
- Tcl_DString *dsPtr; /* Where to store value(s). */
-{
- FileInfo *infoPtr;
- DCB dcb;
- int len;
-
- infoPtr = (FileInfo *) instanceData;
-
- if (optionName == NULL) {
- Tcl_DStringAppendElement(dsPtr, "-mode");
- len = 0;
- } else {
- len = strlen(optionName);
- }
- if ((len == 0) ||
- ((len > 1) && (strncmp(optionName, "-mode", len) == 0))) {
- if (GetCommState(infoPtr->handle, &dcb) == 0) {
- /*
- * shouldn't we flag an error instead ?
- */
- Tcl_DStringAppendElement(dsPtr, "");
- } else {
- char parity;
- char *stop;
- char buf[32];
-
- parity = 'n';
- if (dcb.Parity < 4) {
- parity = "noems"[dcb.Parity];
- }
-
- stop = (dcb.StopBits == ONESTOPBIT) ? "1" :
- (dcb.StopBits == ONE5STOPBITS) ? "1.5" : "2";
-
- wsprintf(buf, "%d,%c,%d,%s", dcb.BaudRate, parity, dcb.ByteSize,
- stop);
- Tcl_DStringAppendElement(dsPtr, buf);
- }
- return TCL_OK;
- } else {
- return Tcl_BadChannelOption(interp, optionName, "mode");
- }
-}
/*
*----------------------------------------------------------------------
@@ -853,28 +659,27 @@ TclpOpenFileChannel(interp, fileName, modeString, permissions)
* file, with what modes to create
* it? */
{
- FileInfo *infoPtr;
+ Tcl_Channel channel = 0;
int seekFlag, mode, channelPermissions;
- DWORD accessMode, createMode, shareMode, flags;
- char *nativeName;
- Tcl_DString buffer;
+ DWORD accessMode, createMode, shareMode, flags, consoleParams, type;
+ TCHAR *nativeName;
+ Tcl_DString ds, buffer;
DCB dcb;
- Tcl_ChannelType *channelTypePtr;
HANDLE handle;
-
- if (!initialized) {
- FileInit();
- }
+ char channelName[16 + TCL_INTEGER_SPACE];
+ TclFile readFile = NULL;
+ TclFile writeFile = NULL;
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);
switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) {
case O_RDONLY:
@@ -930,7 +735,7 @@ TclpOpenFileChannel(interp, fileName, modeString, permissions)
flags = FILE_ATTRIBUTE_READONLY;
}
} else {
- flags = GetFileAttributes(nativeName);
+ flags = (*tclWinProcs->getFileAttributesProc)(nativeName);
if (flags == 0xFFFFFFFF) {
flags = 0;
}
@@ -946,13 +751,11 @@ TclpOpenFileChannel(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;
-
- openerr:
err = GetLastError();
if ((err & 0xffffL) == ERROR_OPEN_FAILED) {
err = (mode & O_CREAT) ? ERROR_FILE_EXISTS : ERROR_FILE_NOT_FOUND;
@@ -960,87 +763,82 @@ TclpOpenFileChannel(interp, fileName, modeString, permissions)
TclWinConvertError(err);
if (interp != (Tcl_Interp *) NULL) {
Tcl_AppendResult(interp, "couldn't open \"", fileName, "\": ",
- Tcl_PosixError(interp), (char *) NULL);
+ Tcl_PosixError(interp), (char *) NULL);
}
Tcl_DStringFree(&buffer);
return NULL;
}
+
+ type = GetFileType(handle);
- if (GetFileType(handle) == FILE_TYPE_CHAR) {
- dcb.DCBlength = sizeof( DCB ) ;
- if (GetCommState(handle, &dcb)) {
- /*
- * This is a com port. Reopen it with the correct modes.
- */
-
- COMMTIMEOUTS cto;
-
- CloseHandle(handle);
- handle = CreateFile(nativeName, accessMode, 0, NULL, OPEN_EXISTING,
- flags, NULL);
- if (handle == INVALID_HANDLE_VALUE) {
- goto openerr;
- }
+ /*
+ * If the file is a character device, we need to try to figure out
+ * whether it is a serial port, a console, or something else. We
+ * test for the console case first because this is more common.
+ */
- /*
- * FileInit the com port.
- */
-
- SetCommMask(handle, EV_RXCHAR);
- SetupComm(handle, 4096, 4096);
- PurgeComm(handle, PURGE_TXABORT | PURGE_RXABORT | PURGE_TXCLEAR
- | PURGE_RXCLEAR);
- cto.ReadIntervalTimeout = MAXDWORD;
- cto.ReadTotalTimeoutMultiplier = 0;
- cto.ReadTotalTimeoutConstant = 0;
- cto.WriteTotalTimeoutMultiplier = 0;
- cto.WriteTotalTimeoutConstant = 0;
- SetCommTimeouts(handle, &cto);
-
- GetCommState(handle, &dcb);
- SetCommState(handle, &dcb);
- channelTypePtr = &comChannelType;
+ if (type == FILE_TYPE_CHAR) {
+ if (GetConsoleMode(handle, &consoleParams)) {
+ type = FILE_TYPE_CONSOLE;
} else {
- channelTypePtr = &fileChannelType;
+ dcb.DCBlength = sizeof( DCB ) ;
+ if (GetCommState(handle, &dcb)) {
+ type = FILE_TYPE_SERIAL;
+ }
}
- } else {
- channelTypePtr = &fileChannelType;
}
- Tcl_DStringFree(&buffer);
- infoPtr = (FileInfo *) ckalloc((unsigned) sizeof(FileInfo));
- infoPtr->nextPtr = firstFilePtr;
- firstFilePtr = infoPtr;
- infoPtr->validMask = channelPermissions;
- infoPtr->watchMask = 0;
- infoPtr->flags = (mode & O_APPEND) ? FILE_APPEND : 0;
- infoPtr->handle = handle;
-
- sprintf(channelName, "file%d", (int) handle);
-
- infoPtr->channel = Tcl_CreateChannel(channelTypePtr, channelName,
- (ClientData) infoPtr, channelPermissions);
-
- if (seekFlag) {
- if (Tcl_Seek(infoPtr->channel, 0, SEEK_END) < 0) {
- if (interp != (Tcl_Interp *) NULL) {
- Tcl_AppendResult(interp, "could not seek to end of file on \"",
- channelName, "\": ", Tcl_PosixError(interp),
- (char *) NULL);
- }
- Tcl_Close(NULL, infoPtr->channel);
- return NULL;
- }
+ channel = NULL;
+
+ switch (type)
+ {
+ case FILE_TYPE_SERIAL:
+ channel = TclWinOpenSerialChannel(handle, channelName,
+ channelPermissions);
+ break;
+ case FILE_TYPE_CONSOLE:
+ channel = TclWinOpenConsoleChannel(handle, channelName,
+ channelPermissions);
+ break;
+ case FILE_TYPE_PIPE:
+ if (channelPermissions & TCL_READABLE)
+ {
+ readFile = TclWinMakeFile(handle);
+ }
+ if (channelPermissions & TCL_WRITABLE)
+ {
+ writeFile = TclWinMakeFile(handle);
+ }
+ channel = TclpCreateCommandChannel(readFile, writeFile, NULL, 0, NULL);
+ break;
+ case FILE_TYPE_CHAR:
+ default:
+ channel = TclWinOpenFileChannel(handle, channelName,
+ channelPermissions,
+ (mode & O_APPEND) ? FILE_APPEND : 0);
+ break;
+
}
- /*
- * Files have default translation of AUTO and ^Z eof char, which
- * means that a ^Z will be appended to them at close.
- */
-
- Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
- Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}");
- return infoPtr->channel;
+ Tcl_DStringFree(&buffer);
+ Tcl_DStringFree(&ds);
+
+ if (channel != NULL)
+ {
+ if (seekFlag) {
+ if (Tcl_Seek(channel, 0, SEEK_END) < 0) {
+ if (interp != (Tcl_Interp *) NULL) {
+ Tcl_AppendResult(interp,
+ "could not seek to end of file on \"",
+ channelName, "\": ", Tcl_PosixError(interp),
+ (char *) NULL);
+ }
+ Tcl_Close(NULL, channel);
+ return NULL;
+ }
+ }
+ }
+ return channel;
}
/*
@@ -1061,57 +859,78 @@ TclpOpenFileChannel(interp, fileName, modeString, permissions)
*/
Tcl_Channel
-Tcl_MakeFileChannel(handle, mode)
- ClientData handle; /* OS level handle */
+Tcl_MakeFileChannel(rawHandle, mode)
+ ClientData rawHandle; /* OS level handle */
int mode; /* ORed combination of TCL_READABLE and
* TCL_WRITABLE to indicate file mode. */
{
- char channelName[20];
- FileInfo *infoPtr;
-
- if (!initialized) {
- FileInit();
- }
+ char channelName[16 + TCL_INTEGER_SPACE];
+ Tcl_Channel channel = NULL;
+ HANDLE handle = (HANDLE) rawHandle;
+ DCB dcb;
+ DWORD consoleParams;
+ DWORD type;
+ TclFile readFile = NULL;
+ TclFile writeFile = NULL;
if (mode == 0) {
return NULL;
}
- sprintf(channelName, "file%d", (int) handle);
+ type = GetFileType(handle);
/*
- * See if a channel with this handle already exists.
+ * If the file is a character device, we need to try to figure out
+ * whether it is a serial port, a console, or something else. We
+ * test for the console case first because this is more common.
*/
-
- for (infoPtr = firstFilePtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
- if (infoPtr->handle == (HANDLE) handle) {
- return (mode == infoPtr->validMask) ? infoPtr->channel : NULL;
+
+ if (type == FILE_TYPE_CHAR) {
+ if (GetConsoleMode(handle, &consoleParams)) {
+ type = FILE_TYPE_CONSOLE;
+ } else {
+ dcb.DCBlength = sizeof( DCB ) ;
+ if (GetCommState(handle, &dcb)) {
+ type = FILE_TYPE_SERIAL;
+ }
}
}
- infoPtr = (FileInfo *) ckalloc((unsigned) sizeof(FileInfo));
- infoPtr->nextPtr = firstFilePtr;
- firstFilePtr = infoPtr;
- infoPtr->validMask = mode;
- infoPtr->watchMask = 0;
- infoPtr->flags = 0;
- infoPtr->handle = (HANDLE) handle;
- infoPtr->channel = Tcl_CreateChannel(&fileChannelType, channelName,
- (ClientData) infoPtr, mode);
+ switch (type)
+ {
+ case FILE_TYPE_SERIAL:
+ channel = TclWinOpenSerialChannel(handle, channelName, mode);
+ break;
+ case FILE_TYPE_CONSOLE:
+ channel = TclWinOpenConsoleChannel(handle, channelName, mode);
+ break;
+ case FILE_TYPE_PIPE:
+ if (mode & TCL_READABLE)
+ {
+ readFile = TclWinMakeFile(handle);
+ }
+ if (mode & TCL_WRITABLE)
+ {
+ writeFile = TclWinMakeFile(handle);
+ }
+ channel = TclpCreateCommandChannel(readFile, writeFile, NULL, 0, NULL);
+ break;
+ case FILE_TYPE_UNKNOWN:
+ break;
+ case FILE_TYPE_CHAR:
+ default:
+ channel = TclWinOpenFileChannel(handle, channelName, mode, 0);
+ break;
- /*
- * Windows files have AUTO translation mode and ^Z eof char on input.
- */
-
- Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
- Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}");
- return infoPtr->channel;
+ }
+
+ return channel;
}
/*
*----------------------------------------------------------------------
*
- * TclGetDefaultStdChannel --
+ * TclpGetDefaultStdChannel --
*
* Constructs a channel for the specified standard OS handle.
*
@@ -1126,7 +945,7 @@ Tcl_MakeFileChannel(handle, mode)
*/
Tcl_Channel
-TclGetDefaultStdChannel(type)
+TclpGetDefaultStdChannel(type)
int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */
{
Tcl_Channel channel;
@@ -1187,3 +1006,72 @@ TclGetDefaultStdChannel(type)
}
return channel;
}
+
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclWinOpenFileChannel --
+ *
+ * Constructs a File channel for the specified standard OS handle.
+ * This is a helper function to break up the construction of
+ * channels into File, Console, or Serial.
+ *
+ * Results:
+ * Returns the new channel, or NULL.
+ *
+ * Side effects:
+ * May open the channel and may cause creation of a file on the
+ * file system.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Channel
+TclWinOpenFileChannel(handle, channelName, permissions, appendMode)
+ HANDLE handle;
+ char *channelName;
+ int permissions;
+ int appendMode;
+{
+ FileInfo *infoPtr;
+ ThreadSpecificData *tsdPtr;
+
+ tsdPtr = FileInit();
+
+ /*
+ * See if a channel with this handle already exists.
+ */
+
+ for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
+ infoPtr = infoPtr->nextPtr) {
+ if (infoPtr->handle == (HANDLE) handle) {
+ return (permissions == infoPtr->validMask) ? infoPtr->channel : NULL;
+ }
+ }
+
+ infoPtr = (FileInfo *) ckalloc((unsigned) sizeof(FileInfo));
+ infoPtr->nextPtr = tsdPtr->firstFilePtr;
+ tsdPtr->firstFilePtr = infoPtr;
+ infoPtr->validMask = permissions;
+ infoPtr->watchMask = 0;
+ infoPtr->flags = appendMode;
+ infoPtr->handle = handle;
+
+ wsprintfA(channelName, "file%lx", (int) infoPtr);
+
+ infoPtr->channel = Tcl_CreateChannel(&fileChannelType, channelName,
+ (ClientData) infoPtr, permissions);
+
+ /*
+ * Files have default translation of AUTO and ^Z eof char, which
+ * means that a ^Z will be accepted as EOF when reading.
+ */
+
+ Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
+ Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}");
+
+ return infoPtr->channel;
+}
+
diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c
new file mode 100644
index 0000000..bd50859
--- /dev/null
+++ b/win/tclWinConsole.c
@@ -0,0 +1,1272 @@
+/*
+ * tclWinConsole.c --
+ *
+ * This file implements the Windows-specific console functions,
+ * and the "console" channel driver.
+ *
+ * Copyright (c) 1999 by Scriptics Corp.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tclWinConsole.c,v 1.2 1999/04/16 00:48:07 stanton Exp $
+ */
+
+#include "tclWinInt.h"
+
+#include <dos.h>
+#include <fcntl.h>
+#include <io.h>
+#include <sys/stat.h>
+
+/*
+ * The following variable is used to tell whether this module has been
+ * initialized.
+ */
+
+static int initialized = 0;
+
+/*
+ * The consoleMutex locks around access to the initialized variable, and it is
+ * used to protect background threads from being terminated while they are
+ * using APIs that hold locks.
+ */
+
+TCL_DECLARE_MUTEX(consoleMutex)
+
+/*
+ * Bit masks used in the flags field of the ConsoleInfo structure below.
+ */
+
+#define CONSOLE_PENDING (1<<0) /* Message is pending in the queue. */
+#define CONSOLE_ASYNC (1<<1) /* Channel is non-blocking. */
+
+/*
+ * Bit masks used in the sharedFlags field of the ConsoleInfo structure below.
+ */
+
+#define CONSOLE_EOF (1<<2) /* Console has reached EOF. */
+#define CONSOLE_BUFFERED (1<<3) /* data was read into a buffer by the reader
+ thread */
+
+#define CONSOLE_BUFFER_SIZE (8*1024)
+/*
+ * This structure describes per-instance data for a console based channel.
+ */
+
+typedef struct ConsoleInfo {
+ HANDLE handle;
+ int type;
+ struct ConsoleInfo *nextPtr;/* Pointer to next registered console. */
+ Tcl_Channel channel; /* Pointer to channel structure. */
+ int validMask; /* OR'ed combination of TCL_READABLE,
+ * TCL_WRITABLE, or TCL_EXCEPTION: indicates
+ * which operations are valid on the file. */
+ int watchMask; /* OR'ed combination of TCL_READABLE,
+ * TCL_WRITABLE, or TCL_EXCEPTION: indicates
+ * which events should be reported. */
+ int flags; /* State flags, see above for a list. */
+ Tcl_ThreadId threadId; /* Thread to which events should be reported.
+ * This value is used by the reader/writer
+ * threads. */
+ HANDLE writeThread; /* Handle to writer thread. */
+ HANDLE readThread; /* Handle to reader thread. */
+ HANDLE writable; /* Manual-reset event to signal when the
+ * writer thread has finished waiting for
+ * the current buffer to be written. */
+ HANDLE readable; /* Manual-reset event to signal when the
+ * reader thread has finished waiting for
+ * input. */
+ HANDLE startWriter; /* Auto-reset event used by the main thread to
+ * signal when the writer thread should attempt
+ * to write to the console. */
+ HANDLE startReader; /* Auto-reset event used by the main thread to
+ * signal when the reader thread should attempt
+ * to read from the console. */
+ DWORD writeError; /* An error caused by the last background
+ * write. Set to 0 if no error has been
+ * detected. This word is shared with the
+ * writer thread so access must be
+ * synchronized with the writable object.
+ */
+ char *writeBuf; /* Current background output buffer.
+ * Access is synchronized with the writable
+ * object. */
+ int writeBufLen; /* Size of write buffer. Access is
+ * synchronized with the writable
+ * object. */
+ int toWrite; /* Current amount to be written. Access is
+ * synchronized with the writable object. */
+ int readFlags; /* Flags that are shared with the reader
+ * thread. Access is synchronized with the
+ * readable object. */
+ int bytesRead; /* number of bytes in the buffer */
+ int offset; /* number of bytes read out of the buffer */
+ char buffer[CONSOLE_BUFFER_SIZE];
+ /* Data consumed by reader thread. */
+} ConsoleInfo;
+
+typedef struct ThreadSpecificData {
+ /*
+ * The following pointer refers to the head of the list of consoles
+ * that are being watched for file events.
+ */
+
+ ConsoleInfo *firstConsolePtr;
+} ThreadSpecificData;
+
+static Tcl_ThreadDataKey dataKey;
+
+/*
+ * The following structure is what is added to the Tcl event queue when
+ * console events are generated.
+ */
+
+typedef struct ConsoleEvent {
+ Tcl_Event header; /* Information that is standard for
+ * all events. */
+ ConsoleInfo *infoPtr; /* Pointer to console info structure. Note
+ * that we still have to verify that the
+ * console exists before dereferencing this
+ * pointer. */
+} ConsoleEvent;
+
+/*
+ * Declarations for functions used only in this file.
+ */
+
+static int ApplicationType(Tcl_Interp *interp,
+ const char *fileName, char *fullName);
+static void BuildCommandLine(const char *executable, int argc,
+ char **argv, Tcl_DString *linePtr);
+static void CopyChannel(HANDLE dst, HANDLE src);
+static BOOL HasConsole(void);
+static TclFile MakeFile(HANDLE handle);
+static char * MakeTempFile(Tcl_DString *namePtr);
+static int ConsoleBlockModeProc(ClientData instanceData, int mode);
+static void ConsoleCheckProc(ClientData clientData, int flags);
+static int ConsoleCloseProc(ClientData instanceData,
+ Tcl_Interp *interp);
+static int ConsoleEventProc(Tcl_Event *evPtr, int flags);
+static void ConsoleExitHandler(ClientData clientData);
+static int ConsoleGetHandleProc(ClientData instanceData,
+ int direction, ClientData *handlePtr);
+static ThreadSpecificData *ConsoleInit(void);
+static int ConsoleInputProc(ClientData instanceData, char *buf,
+ int toRead, int *errorCode);
+static int ConsoleOutputProc(ClientData instanceData, char *buf,
+ int toWrite, int *errorCode);
+static DWORD WINAPI ConsoleReaderThread(LPVOID arg);
+static void ConsoleSetupProc(ClientData clientData, int flags);
+static void ConsoleWatchProc(ClientData instanceData, int mask);
+static DWORD WINAPI ConsoleWriterThread(LPVOID arg);
+static void ProcExitHandler(ClientData clientData);
+static int TempFileName(WCHAR name[MAX_PATH]);
+static int WaitForRead(ConsoleInfo *infoPtr, int blocking);
+
+/*
+ * This structure describes the channel type structure for command console
+ * based IO.
+ */
+
+static Tcl_ChannelType consoleChannelType = {
+ "console", /* Type name. */
+ ConsoleBlockModeProc, /* Set blocking or non-blocking mode.*/
+ ConsoleCloseProc, /* Close proc. */
+ ConsoleInputProc, /* Input proc. */
+ ConsoleOutputProc, /* Output proc. */
+ NULL, /* Seek proc. */
+ NULL, /* Set option proc. */
+ NULL, /* Get option proc. */
+ ConsoleWatchProc, /* Set up notifier to watch the channel. */
+ ConsoleGetHandleProc, /* Get an OS handle from channel. */
+};
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ConsoleInit --
+ *
+ * This function initializes the static variables for this file.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Creates a new event source.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static ThreadSpecificData *
+ConsoleInit()
+{
+ ThreadSpecificData *tsdPtr;
+
+ /*
+ * Check the initialized flag first, then check again in the mutex.
+ * This is a speed enhancement.
+ */
+
+ if (!initialized) {
+ Tcl_MutexLock(&consoleMutex);
+ if (!initialized) {
+ initialized = 1;
+ Tcl_CreateExitHandler(ProcExitHandler, NULL);
+ }
+ Tcl_MutexUnlock(&consoleMutex);
+ }
+
+ tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
+ if (tsdPtr == NULL) {
+ tsdPtr = TCL_TSD_INIT(&dataKey);
+ tsdPtr->firstConsolePtr = NULL;
+ Tcl_CreateEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL);
+ Tcl_CreateThreadExitHandler(ConsoleExitHandler, NULL);
+ }
+ return tsdPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ConsoleExitHandler --
+ *
+ * This function is called to cleanup the console module before
+ * Tcl is unloaded.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Removes the console event source.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+ConsoleExitHandler(
+ ClientData clientData) /* Old window proc */
+{
+ Tcl_DeleteEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ProcExitHandler --
+ *
+ * This function is called to cleanup the process list before
+ * Tcl is unloaded.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Resets the process list.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+ProcExitHandler(
+ ClientData clientData) /* Old window proc */
+{
+ Tcl_MutexLock(&consoleMutex);
+ initialized = 0;
+ Tcl_MutexUnlock(&consoleMutex);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ConsoleSetupProc --
+ *
+ * This procedure is invoked before Tcl_DoOneEvent blocks waiting
+ * for an event.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Adjusts the block time if needed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+ConsoleSetupProc(
+ ClientData data, /* Not used. */
+ int flags) /* Event flags as passed to Tcl_DoOneEvent. */
+{
+ ConsoleInfo *infoPtr;
+ Tcl_Time blockTime = { 0, 0 };
+ int block = 1;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ if (!(flags & TCL_FILE_EVENTS)) {
+ return;
+ }
+
+ /*
+ * Look to see if any events are already pending. If they are, poll.
+ */
+
+ for (infoPtr = tsdPtr->firstConsolePtr; infoPtr != NULL;
+ infoPtr = infoPtr->nextPtr) {
+ if (infoPtr->watchMask & TCL_WRITABLE) {
+ if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) {
+ block = 0;
+ }
+ }
+ if (infoPtr->watchMask & TCL_READABLE) {
+ if (WaitForRead(infoPtr, 0) >= 0) {
+ block = 0;
+ }
+ }
+ }
+ if (!block) {
+ Tcl_SetMaxBlockTime(&blockTime);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ConsoleCheckProc --
+ *
+ * This procedure is called by Tcl_DoOneEvent to check the console
+ * event source for events.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * May queue an event.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+ConsoleCheckProc(
+ ClientData data, /* Not used. */
+ int flags) /* Event flags as passed to Tcl_DoOneEvent. */
+{
+ ConsoleInfo *infoPtr;
+ ConsoleEvent *evPtr;
+ int needEvent;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ if (!(flags & TCL_FILE_EVENTS)) {
+ return;
+ }
+
+ /*
+ * Queue events for any ready consoles that don't already have events
+ * queued.
+ */
+
+ for (infoPtr = tsdPtr->firstConsolePtr; infoPtr != NULL;
+ infoPtr = infoPtr->nextPtr) {
+ if (infoPtr->flags & CONSOLE_PENDING) {
+ continue;
+ }
+
+ /*
+ * Queue an event if the console is signaled for reading or writing.
+ */
+
+ needEvent = 0;
+ if (infoPtr->watchMask & TCL_WRITABLE) {
+ if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) {
+ needEvent = 1;
+ }
+ }
+
+ if (infoPtr->watchMask & TCL_READABLE) {
+ if (WaitForRead(infoPtr, 0) >= 0) {
+ needEvent = 1;
+ }
+ }
+
+ if (needEvent) {
+ infoPtr->flags |= CONSOLE_PENDING;
+ evPtr = (ConsoleEvent *) ckalloc(sizeof(ConsoleEvent));
+ evPtr->header.proc = ConsoleEventProc;
+ evPtr->infoPtr = infoPtr;
+ Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
+ }
+ }
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ConsoleBlockModeProc --
+ *
+ * Set blocking or non-blocking mode on channel.
+ *
+ * Results:
+ * 0 if successful, errno when failed.
+ *
+ * Side effects:
+ * Sets the device into blocking or non-blocking mode.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ConsoleBlockModeProc(
+ ClientData instanceData, /* Instance data for channel. */
+ int mode) /* TCL_MODE_BLOCKING or
+ * TCL_MODE_NONBLOCKING. */
+{
+ ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData;
+
+ /*
+ * Consoles on Windows can not be switched between blocking and nonblocking,
+ * hence we have to emulate the behavior. This is done in the input
+ * function by checking against a bit in the state. We set or unset the
+ * bit here to cause the input function to emulate the correct behavior.
+ */
+
+ if (mode == TCL_MODE_NONBLOCKING) {
+ infoPtr->flags |= CONSOLE_ASYNC;
+ } else {
+ infoPtr->flags &= ~(CONSOLE_ASYNC);
+ }
+ return 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ConsoleCloseProc --
+ *
+ * Closes a console based IO channel.
+ *
+ * Results:
+ * 0 on success, errno otherwise.
+ *
+ * Side effects:
+ * Closes the physical channel.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ConsoleCloseProc(
+ ClientData instanceData, /* Pointer to ConsoleInfo structure. */
+ Tcl_Interp *interp) /* For error reporting. */
+{
+ ConsoleInfo *consolePtr = (ConsoleInfo *) instanceData;
+ int errorCode;
+ ConsoleInfo *infoPtr, **nextPtrPtr;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ errorCode = 0;
+
+ /*
+ * Clean up the background thread if necessary. Note that this
+ * must be done before we can close the file, since the
+ * thread may be blocking trying to read from the console.
+ */
+
+ if (consolePtr->readThread) {
+ /*
+ * Forcibly terminate the background thread. We cannot rely on the
+ * thread to cleanly terminate itself because we have no way of
+ * closing the handle without blocking in the case where the
+ * thread is in the middle of an I/O operation. Note that we need
+ * to guard against terminating the thread while it is in the
+ * middle of Tcl_ThreadAlert because it won't be able to release
+ * the notifier lock.
+ */
+
+ Tcl_MutexLock(&consoleMutex);
+ TerminateThread(consolePtr->readThread, 0);
+ Tcl_MutexUnlock(&consoleMutex);
+
+ /*
+ * Wait for the thread to terminate. This ensures that we are
+ * completely cleaned up before we leave this function.
+ */
+
+ WaitForSingleObject(consolePtr->readThread, INFINITE);
+ CloseHandle(consolePtr->readThread);
+ CloseHandle(consolePtr->readable);
+ CloseHandle(consolePtr->startReader);
+ consolePtr->readThread = NULL;
+ }
+ consolePtr->validMask &= ~TCL_READABLE;
+
+ /*
+ * Wait for the writer thread to finish the current buffer, then
+ * terminate the thread and close the handles. If the channel is
+ * nonblocking, there should be no pending write operations.
+ */
+
+ if (consolePtr->writeThread) {
+ WaitForSingleObject(consolePtr->writable, INFINITE);
+
+ /*
+ * Forcibly terminate the background thread. We cannot rely on the
+ * thread to cleanly terminate itself because we have no way of
+ * closing the handle without blocking in the case where the
+ * thread is in the middle of an I/O operation. Note that we need
+ * to guard against terminating the thread while it is in the
+ * middle of Tcl_ThreadAlert because it won't be able to release
+ * the notifier lock.
+ */
+
+ Tcl_MutexLock(&consoleMutex);
+ TerminateThread(consolePtr->writeThread, 0);
+ Tcl_MutexUnlock(&consoleMutex);
+
+ /*
+ * Wait for the thread to terminate. This ensures that we are
+ * completely cleaned up before we leave this function.
+ */
+
+ WaitForSingleObject(consolePtr->writeThread, INFINITE);
+ CloseHandle(consolePtr->writeThread);
+ CloseHandle(consolePtr->writable);
+ CloseHandle(consolePtr->startWriter);
+ consolePtr->writeThread = NULL;
+ }
+ consolePtr->validMask &= ~TCL_WRITABLE;
+
+
+ /*
+ * Don't close the Win32 handle if the handle is a standard channel
+ * during the exit process. Otherwise, one thread may kill the stdio
+ * of another.
+ */
+
+ if (!TclInExit()
+ || ((GetStdHandle(STD_INPUT_HANDLE) != consolePtr->handle)
+ && (GetStdHandle(STD_OUTPUT_HANDLE) != consolePtr->handle)
+ && (GetStdHandle(STD_ERROR_HANDLE) != consolePtr->handle))) {
+ if (CloseHandle(consolePtr->handle) == FALSE) {
+ TclWinConvertError(GetLastError());
+ errorCode = errno;
+ }
+ }
+
+ consolePtr->watchMask &= consolePtr->validMask;
+
+ /*
+ * Remove the file from the list of watched files.
+ */
+
+ for (nextPtrPtr = &(tsdPtr->firstConsolePtr), infoPtr = *nextPtrPtr;
+ infoPtr != NULL;
+ nextPtrPtr = &infoPtr->nextPtr, infoPtr = *nextPtrPtr) {
+ if (infoPtr == (ConsoleInfo *)consolePtr) {
+ *nextPtrPtr = infoPtr->nextPtr;
+ break;
+ }
+ }
+ if (consolePtr->writeBuf != NULL) {
+ ckfree(consolePtr->writeBuf);
+ consolePtr->writeBuf = 0;
+ }
+ ckfree((char*) consolePtr);
+
+ return errorCode;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ConsoleInputProc --
+ *
+ * Reads input from the IO channel into the buffer given. Returns
+ * count of how many bytes were actually read, and an error indication.
+ *
+ * Results:
+ * A count of how many bytes were read is returned and an error
+ * indication is returned in an output argument.
+ *
+ * Side effects:
+ * Reads input from the actual channel.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ConsoleInputProc(
+ ClientData instanceData, /* Console state. */
+ char *buf, /* Where to store data read. */
+ int bufSize, /* How much space is available
+ * in the buffer? */
+ int *errorCode) /* Where to store error code. */
+{
+ ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData;
+ DWORD count, bytesRead = 0;
+ int result;
+
+ *errorCode = 0;
+
+ /*
+ * Synchronize with the reader thread.
+ */
+
+ result = WaitForRead(infoPtr, (infoPtr->flags & CONSOLE_ASYNC) ? 0 : 1);
+
+ /*
+ * If an error occurred, return immediately.
+ */
+
+ if (result == -1) {
+ *errorCode = errno;
+ return -1;
+ }
+
+ if (infoPtr->readFlags & CONSOLE_BUFFERED) {
+ /*
+ * Data is stored in the buffer.
+ */
+
+ if (bufSize < (infoPtr->bytesRead - infoPtr->offset)) {
+ memcpy(buf, &infoPtr->buffer[infoPtr->offset], bufSize);
+ bytesRead = bufSize;
+ infoPtr->offset += bufSize;
+ } else {
+ memcpy(buf, &infoPtr->buffer[infoPtr->offset], bufSize);
+ bytesRead = infoPtr->bytesRead - infoPtr->offset;
+
+ /*
+ * Reset the buffer
+ */
+
+ infoPtr->readFlags &= ~CONSOLE_BUFFERED;
+ infoPtr->offset = 0;
+ }
+
+ return bytesRead;
+ }
+
+ /*
+ * Attempt to read bufSize bytes. The read will return immediately
+ * if there is any data available. Otherwise it will block until
+ * at least one byte is available or an EOF occurs.
+ */
+
+ if (ReadConsole(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize, &count,
+ (LPOVERLAPPED) NULL) == TRUE) {
+ buf[count] = '\0';
+ return count;
+ }
+
+ return -1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ConsoleOutputProc --
+ *
+ * Writes the given output on the IO channel. Returns count of how
+ * many characters were actually written, and an error indication.
+ *
+ * Results:
+ * A count of how many characters were written is returned and an
+ * error indication is returned in an output argument.
+ *
+ * Side effects:
+ * Writes output on the actual channel.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ConsoleOutputProc(
+ ClientData instanceData, /* Console state. */
+ char *buf, /* The data buffer. */
+ int toWrite, /* How many bytes to write? */
+ int *errorCode) /* Where to store error code. */
+{
+ ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData;
+ DWORD bytesWritten, timeout;
+
+ *errorCode = 0;
+ timeout = (infoPtr->flags & CONSOLE_ASYNC) ? 0 : INFINITE;
+ if (WaitForSingleObject(infoPtr->writable, timeout) == WAIT_TIMEOUT) {
+ /*
+ * The writer thread is blocked waiting for a write to complete
+ * and the channel is in non-blocking mode.
+ */
+
+ errno = EAGAIN;
+ goto error;
+ }
+
+ /*
+ * Check for a background error on the last write.
+ */
+
+ if (infoPtr->writeError) {
+ TclWinConvertError(infoPtr->writeError);
+ infoPtr->writeError = 0;
+ goto error;
+ }
+
+ if (infoPtr->flags & CONSOLE_ASYNC) {
+ /*
+ * The console is non-blocking, so copy the data into the output
+ * buffer and restart the writer thread.
+ */
+
+ if (toWrite > infoPtr->writeBufLen) {
+ /*
+ * Reallocate the buffer to be large enough to hold the data.
+ */
+
+ if (infoPtr->writeBuf) {
+ ckfree(infoPtr->writeBuf);
+ }
+ infoPtr->writeBufLen = toWrite;
+ infoPtr->writeBuf = ckalloc(toWrite);
+ }
+ memcpy(infoPtr->writeBuf, buf, toWrite);
+ infoPtr->toWrite = toWrite;
+ ResetEvent(infoPtr->writable);
+ SetEvent(infoPtr->startWriter);
+ bytesWritten = toWrite;
+ } else {
+ /*
+ * In the blocking case, just try to write the buffer directly.
+ * This avoids an unnecessary copy.
+ */
+
+ if (WriteFile(infoPtr->handle, (LPVOID) buf, (DWORD) toWrite,
+ &bytesWritten, (LPOVERLAPPED) NULL) == FALSE) {
+ TclWinConvertError(GetLastError());
+ goto error;
+ }
+ }
+ return bytesWritten;
+
+ error:
+ *errorCode = errno;
+ return -1;
+
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ConsoleEventProc --
+ *
+ * This function is invoked by Tcl_ServiceEvent when a file event
+ * reaches the front of the event queue. This procedure invokes
+ * Tcl_NotifyChannel on the console.
+ *
+ * Results:
+ * Returns 1 if the event was handled, meaning it should be removed
+ * from the queue. Returns 0 if the event was not handled, meaning
+ * it should stay on the queue. The only time the event isn't
+ * handled is if the TCL_FILE_EVENTS flag bit isn't set.
+ *
+ * Side effects:
+ * Whatever the notifier callback does.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ConsoleEventProc(
+ Tcl_Event *evPtr, /* Event to service. */
+ int flags) /* Flags that indicate what events to
+ * handle, such as TCL_FILE_EVENTS. */
+{
+ ConsoleEvent *consoleEvPtr = (ConsoleEvent *)evPtr;
+ ConsoleInfo *infoPtr;
+ int mask;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ if (!(flags & TCL_FILE_EVENTS)) {
+ return 0;
+ }
+
+ /*
+ * Search through the list of watched consoles for the one whose handle
+ * matches the event. We do this rather than simply dereferencing
+ * the handle in the event so that consoles can be deleted while the
+ * event is in the queue.
+ */
+
+ for (infoPtr = tsdPtr->firstConsolePtr; infoPtr != NULL;
+ infoPtr = infoPtr->nextPtr) {
+ if (consoleEvPtr->infoPtr == infoPtr) {
+ infoPtr->flags &= ~(CONSOLE_PENDING);
+ break;
+ }
+ }
+
+ /*
+ * Remove stale events.
+ */
+
+ if (!infoPtr) {
+ return 1;
+ }
+
+ /*
+ * Check to see if the console is readable. Note
+ * that we can't tell if a console is writable, so we always report it
+ * as being writable unless we have detected EOF.
+ */
+
+ mask = 0;
+ if (infoPtr->watchMask & TCL_WRITABLE) {
+ if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) {
+ mask = TCL_WRITABLE;
+ }
+ }
+
+ if (infoPtr->watchMask & TCL_READABLE) {
+ if (WaitForRead(infoPtr, 0) >= 0) {
+ if (infoPtr->readFlags & CONSOLE_EOF) {
+ mask = TCL_READABLE;
+ } else {
+ mask |= TCL_READABLE;
+ }
+ }
+ }
+
+ /*
+ * Inform the channel of the events.
+ */
+
+ Tcl_NotifyChannel(infoPtr->channel, infoPtr->watchMask & mask);
+ return 1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ConsoleWatchProc --
+ *
+ * Called by the notifier to set up to watch for events on this
+ * channel.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+ConsoleWatchProc(
+ ClientData instanceData, /* Console state. */
+ int mask) /* What events to watch for, OR-ed
+ * combination of TCL_READABLE,
+ * TCL_WRITABLE and TCL_EXCEPTION. */
+{
+ ConsoleInfo **nextPtrPtr, *ptr;
+ ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData;
+ int oldMask = infoPtr->watchMask;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ /*
+ * Since most of the work is handled by the background threads,
+ * we just need to update the watchMask and then force the notifier
+ * to poll once.
+ */
+
+ infoPtr->watchMask = mask & infoPtr->validMask;
+ if (infoPtr->watchMask) {
+ Tcl_Time blockTime = { 0, 0 };
+ if (!oldMask) {
+ infoPtr->nextPtr = tsdPtr->firstConsolePtr;
+ tsdPtr->firstConsolePtr = infoPtr;
+ }
+ Tcl_SetMaxBlockTime(&blockTime);
+ } else {
+ if (oldMask) {
+ /*
+ * Remove the console from the list of watched consoles.
+ */
+
+ for (nextPtrPtr = &(tsdPtr->firstConsolePtr), ptr = *nextPtrPtr;
+ ptr != NULL;
+ nextPtrPtr = &ptr->nextPtr, ptr = *nextPtrPtr) {
+ if (infoPtr == ptr) {
+ *nextPtrPtr = ptr->nextPtr;
+ break;
+ }
+ }
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ConsoleGetHandleProc --
+ *
+ * Called from Tcl_GetChannelHandle to retrieve OS handles from
+ * inside a command consoleline based channel.
+ *
+ * Results:
+ * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if
+ * there is no handle for the specified direction.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ConsoleGetHandleProc(
+ ClientData instanceData, /* The console state. */
+ int direction, /* TCL_READABLE or TCL_WRITABLE */
+ ClientData *handlePtr) /* Where to store the handle. */
+{
+ ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData;
+
+ *handlePtr = (ClientData) infoPtr->handle;
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * WaitForRead --
+ *
+ * Wait until some data is available, the console is at
+ * EOF or the reader thread is blocked waiting for data (if the
+ * channel is in non-blocking mode).
+ *
+ * Results:
+ * Returns 1 if console is readable. Returns 0 if there is no data
+ * on the console, but there is buffered data. Returns -1 if an
+ * error occurred. If an error occurred, the threads may not
+ * be synchronized.
+ *
+ * Side effects:
+ * Updates the shared state flags. If no error occurred,
+ * the reader thread is blocked waiting for a signal from the
+ * main thread.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+WaitForRead(
+ ConsoleInfo *infoPtr, /* Console state. */
+ int blocking) /* Indicates whether call should be
+ * blocking or not. */
+{
+ DWORD timeout, count;
+ HANDLE *handle = infoPtr->handle;
+ INPUT_RECORD input;
+
+ while (1) {
+ /*
+ * Synchronize with the reader thread.
+ */
+
+ timeout = blocking ? INFINITE : 0;
+ if (WaitForSingleObject(infoPtr->readable, timeout) == WAIT_TIMEOUT) {
+ /*
+ * The reader thread is blocked waiting for data and the channel
+ * is in non-blocking mode.
+ */
+ errno = EAGAIN;
+ return -1;
+ }
+
+ /*
+ * At this point, the two threads are synchronized, so it is safe
+ * to access shared state.
+ */
+
+ /*
+ * If the console has hit EOF, it is always readable.
+ */
+
+ if (infoPtr->readFlags & CONSOLE_EOF) {
+ return 1;
+ }
+
+ if (PeekConsoleInput(handle, &input, 1, &count) == FALSE) {
+ /*
+ * Check to see if the peek failed because of EOF.
+ */
+
+ TclWinConvertError(GetLastError());
+
+ if (errno == EOF) {
+ infoPtr->readFlags |= CONSOLE_EOF;
+ return 1;
+ }
+
+ /*
+ * Ignore errors if there is data in the buffer.
+ */
+
+ if (infoPtr->readFlags & CONSOLE_BUFFERED) {
+ return 0;
+ } else {
+ return -1;
+ }
+ }
+
+ /*
+ * If there is data in the buffer, the console must be
+ * readable (since it is a line-oriented device).
+ */
+
+ if (infoPtr->readFlags & CONSOLE_BUFFERED) {
+ return 1;
+ }
+
+
+ /*
+ * There wasn't any data available, so reset the thread and
+ * try again.
+ */
+
+ ResetEvent(infoPtr->readable);
+ SetEvent(infoPtr->startReader);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ConsoleReaderThread --
+ *
+ * This function runs in a separate thread and waits for input
+ * to become available on a console.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Signals the main thread when input become available. May
+ * cause the main thread to wake up by posting a message. May
+ * one line from the console for each wait operation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static DWORD WINAPI
+ConsoleReaderThread(LPVOID arg)
+{
+ ConsoleInfo *infoPtr = (ConsoleInfo *)arg;
+ HANDLE *handle = infoPtr->handle;
+ DWORD count;
+
+ for (;;) {
+ /*
+ * Wait for the main thread to signal before attempting to wait.
+ */
+
+ WaitForSingleObject(infoPtr->startReader, INFINITE);
+
+ count = 0;
+
+ /*
+ * Look for data on the console, but first ignore any events
+ * that are not KEY_EVENTs
+ */
+ if (ReadConsole(handle, infoPtr->buffer, CONSOLE_BUFFER_SIZE,
+ &infoPtr->bytesRead, NULL) != FALSE) {
+ /*
+ * Data was stored in the buffer.
+ */
+
+ infoPtr->readFlags |= CONSOLE_BUFFERED;
+ } else {
+ DWORD err;
+ err = GetLastError();
+
+ if (err == EOF) {
+ infoPtr->readFlags = CONSOLE_EOF;
+ }
+ }
+
+ /*
+ * Signal the main thread by signalling the readable event and
+ * then waking up the notifier thread.
+ */
+
+ SetEvent(infoPtr->readable);
+
+ /*
+ * Alert the foreground thread. Note that we need to treat this like
+ * a critical section so the foreground thread does not terminate
+ * this thread while we are holding a mutex in the notifier code.
+ */
+
+ Tcl_MutexLock(&consoleMutex);
+ Tcl_ThreadAlert(infoPtr->threadId);
+ Tcl_MutexUnlock(&consoleMutex);
+ }
+ return 0; /* NOT REACHED */
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ConsoleWriterThread --
+ *
+ * This function runs in a separate thread and writes data
+ * onto a console.
+ *
+ * Results:
+ * Always returns 0.
+ *
+ * Side effects:
+ * Signals the main thread when an output operation is completed.
+ * May cause the main thread to wake up by posting a message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static DWORD WINAPI
+ConsoleWriterThread(LPVOID arg)
+{
+
+ ConsoleInfo *infoPtr = (ConsoleInfo *)arg;
+ HANDLE *handle = infoPtr->handle;
+ DWORD count, toWrite;
+ char *buf;
+
+ for (;;) {
+ /*
+ * Wait for the main thread to signal before attempting to write.
+ */
+
+ WaitForSingleObject(infoPtr->startWriter, INFINITE);
+
+ buf = infoPtr->writeBuf;
+ toWrite = infoPtr->toWrite;
+
+ /*
+ * Loop until all of the bytes are written or an error occurs.
+ */
+
+ while (toWrite > 0) {
+ if (WriteFile(handle, buf, toWrite, &count, NULL) == FALSE) {
+ infoPtr->writeError = GetLastError();
+ break;
+ } else {
+ toWrite -= count;
+ buf += count;
+ }
+ }
+
+ /*
+ * Signal the main thread by signalling the writable event and
+ * then waking up the notifier thread.
+ */
+
+ SetEvent(infoPtr->writable);
+
+ /*
+ * Alert the foreground thread. Note that we need to treat this like
+ * a critical section so the foreground thread does not terminate
+ * this thread while we are holding a mutex in the notifier code.
+ */
+
+ Tcl_MutexLock(&consoleMutex);
+ Tcl_ThreadAlert(infoPtr->threadId);
+ Tcl_MutexUnlock(&consoleMutex);
+ }
+ return 0; /* NOT REACHED */
+}
+
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclWinOpenConsoleChannel --
+ *
+ * Constructs a Console channel for the specified standard OS handle.
+ * This is a helper function to break up the construction of
+ * channels into File, Console, or Serial.
+ *
+ * Results:
+ * Returns the new channel, or NULL.
+ *
+ * Side effects:
+ * May open the channel
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Channel
+TclWinOpenConsoleChannel(handle, channelName, permissions)
+ HANDLE handle;
+ char *channelName;
+ int permissions;
+{
+ char encoding[4 + TCL_INTEGER_SPACE];
+ ConsoleInfo *infoPtr;
+ ThreadSpecificData *tsdPtr;
+ DWORD id;
+
+ tsdPtr = ConsoleInit();
+
+ /*
+ * See if a channel with this handle already exists.
+ */
+
+ infoPtr = (ConsoleInfo *) ckalloc((unsigned) sizeof(ConsoleInfo));
+ memset(infoPtr, 0, sizeof(ConsoleInfo));
+
+ infoPtr->validMask = permissions;
+ infoPtr->handle = handle;
+
+ wsprintfA(encoding, "cp%d", GetConsoleCP());
+
+ /*
+ * Use the pointer for the name of the result channel.
+ * This keeps the channel names unique, since some may share
+ * handles (stdin/stdout/stderr for instance).
+ */
+
+ wsprintfA(channelName, "file%lx", (int) infoPtr);
+
+ infoPtr->channel = Tcl_CreateChannel(&consoleChannelType, channelName,
+ (ClientData) infoPtr, permissions);
+
+ infoPtr->threadId = Tcl_GetCurrentThread();
+
+ if (permissions & TCL_READABLE) {
+ infoPtr->readable = CreateEvent(NULL, TRUE, TRUE, NULL);
+ infoPtr->startReader = CreateEvent(NULL, FALSE, FALSE, NULL);
+ infoPtr->readThread = CreateThread(NULL, 8000, ConsoleReaderThread,
+ infoPtr, 0, &id);
+ SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST);
+ }
+
+ if (permissions & TCL_WRITABLE) {
+ infoPtr->writable = CreateEvent(NULL, TRUE, TRUE, NULL);
+ infoPtr->startWriter = CreateEvent(NULL, FALSE, FALSE, NULL);
+ infoPtr->writeThread = CreateThread(NULL, 8000, ConsoleWriterThread,
+ infoPtr, 0, &id);
+ }
+
+ /*
+ * Files have default translation of AUTO and ^Z eof char, which
+ * means that a ^Z will be accepted as EOF when reading.
+ */
+
+ Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
+ Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}");
+ Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", encoding);
+
+ return infoPtr->channel;
+}
diff --git a/win/tclWinDde.c b/win/tclWinDde.c
new file mode 100644
index 0000000..9b0ec82
--- /dev/null
+++ b/win/tclWinDde.c
@@ -0,0 +1,1287 @@
+/*
+ * tclWinDde.c --
+ *
+ * This file provides procedures that implement the "send"
+ * command, allowing commands to be passed from interpreter
+ * to interpreter.
+ *
+ * Copyright (c) 1997 by Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tclWinDde.c,v 1.2 1999/04/16 00:48:08 stanton Exp $
+ */
+
+#include "tclPort.h"
+#include <ddeml.h>
+
+/*
+ * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
+ * Registry_Init declaration is in the source file itself, which is only
+ * accessed when we are building a library.
+ */
+
+#undef TCL_STORAGE_CLASS
+#define TCL_STORAGE_CLASS DLLEXPORT
+
+/*
+ * The following structure is used to keep track of the interpreters
+ * registered by this process.
+ */
+
+typedef struct RegisteredInterp {
+ struct RegisteredInterp *nextPtr;
+ /* The next interp this application knows
+ * about. */
+ char *name; /* Interpreter's name (malloc-ed). */
+ Tcl_Interp *interp; /* The interpreter attached to this name. */
+} RegisteredInterp;
+
+/*
+ * Used to keep track of conversations.
+ */
+
+typedef struct Conversation {
+ struct Conversation *nextPtr;
+ /* The next conversation in the list. */
+ RegisteredInterp *riPtr; /* The info we know about the conversation. */
+ HCONV hConv; /* The DDE handle for this conversation. */
+ Tcl_Obj *returnPackagePtr; /* The result package for this conversation. */
+} Conversation;
+
+typedef struct ThreadSpecificData {
+ Conversation *currentConversations;
+ /* A list of conversations currently
+ * being processed. */
+ RegisteredInterp *interpListPtr;
+ /* List of all interpreters registered
+ * in the current process. */
+} ThreadSpecificData;
+static Tcl_ThreadDataKey dataKey;
+
+/*
+ * The following variables cannot be placed in thread-local storage.
+ * The Mutex ddeMutex guards access to the ddeInstance.
+ */
+static HSZ ddeService = 0;
+static DWORD ddeInstance; /* The application instance handle given
+ * to us by DdeInitialize. */
+static int ddeIsServer = 0;
+
+TCL_DECLARE_MUTEX(ddeMutex)
+
+/*
+ * Forward declarations for procedures defined later in this file.
+ */
+
+static void DdeExitProc _ANSI_ARGS_((ClientData clientData));
+static void DeleteProc _ANSI_ARGS_((ClientData clientData));
+static Tcl_Obj * ExecuteRemoteObject _ANSI_ARGS_((
+ RegisteredInterp *riPtr,
+ Tcl_Obj *ddeObjectPtr));
+static int MakeDdeConnection _ANSI_ARGS_((Tcl_Interp *interp,
+ char *name, HCONV *ddeConvPtr));
+static HDDEDATA CALLBACK DdeServerProc _ANSI_ARGS_((UINT uType,
+ UINT uFmt, HCONV hConv, HSZ ddeTopic,
+ HSZ ddeItem, HDDEDATA hData, DWORD dwData1,
+ DWORD dwData2));
+static void SetDdeError _ANSI_ARGS_((Tcl_Interp *interp));
+int Tcl_DdeObjCmd(ClientData clientData, /* Used only for deletion */
+ Tcl_Interp *interp, /* The interp we are sending from */
+ int objc, /* Number of arguments */
+ Tcl_Obj *CONST objv[]); /* The arguments */
+
+EXTERN int Dde_Init(Tcl_Interp *interp);
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Dde_Init --
+ *
+ * This procedure initializes the dde command.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Dde_Init(
+ Tcl_Interp *interp)
+{
+ ThreadSpecificData *tsdPtr;
+
+ if (!Tcl_InitStubs(interp, "8.0", 0)) {
+ return TCL_ERROR;
+ }
+
+ Tcl_CreateObjCommand(interp, "dde", Tcl_DdeObjCmd, NULL, NULL);
+
+ tsdPtr = (ThreadSpecificData *)
+ Tcl_GetThreadData((Tcl_ThreadDataKey *) &dataKey, sizeof(ThreadSpecificData));
+
+ if (tsdPtr == NULL) {
+ tsdPtr = TCL_TSD_INIT(&dataKey);
+ tsdPtr->currentConversations = NULL;
+ tsdPtr->interpListPtr = NULL;
+ }
+ Tcl_CreateExitHandler(DdeExitProc, NULL);
+
+ return Tcl_PkgProvide(interp, "dde", "1.0");
+}
+
+
+
+static void
+Initialize()
+{
+ int nameFound = 0;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ /*
+ * See if the application is already registered; if so, remove its
+ * current name from the registry. The deletion of the command
+ * will take care of disposing of this entry.
+ */
+
+ if (tsdPtr->interpListPtr != NULL) {
+ nameFound = 1;
+ }
+
+ /*
+ * Make sure that the DDE server is there. This is done only once,
+ * add an exit handler tear it down.
+ */
+
+ if (ddeInstance == 0) {
+ Tcl_MutexLock(&ddeMutex);
+ if (ddeInstance == 0) {
+ if (DdeInitialize(&ddeInstance, DdeServerProc,
+ CBF_SKIP_REGISTRATIONS
+ | CBF_SKIP_UNREGISTRATIONS
+ | CBF_FAIL_POKES, 0)
+ != DMLERR_NO_ERROR) {
+ DdeUninitialize(ddeInstance);
+ ddeInstance = 0;
+ }
+ }
+ Tcl_MutexUnlock(&ddeMutex);
+ }
+ if ((ddeService == 0) && (nameFound != 0)) {
+ Tcl_MutexLock(&ddeMutex);
+ if ((ddeService == 0) && (nameFound != 0)) {
+ ddeIsServer = 1;
+ Tcl_CreateExitHandler(DdeExitProc, NULL);
+ ddeService = DdeCreateStringHandle(ddeInstance, "TclEval", 0);
+ DdeNameService(ddeInstance, ddeService, 0L, DNS_REGISTER);
+ } else {
+ ddeIsServer = 0;
+ }
+ Tcl_MutexUnlock(&ddeMutex);
+ }
+}
+
+
+/*
+ *--------------------------------------------------------------
+ *
+ * DdeSetServerName --
+ *
+ * This procedure is called to associate an ASCII name with a Dde
+ * server. If the interpreter has already been named, the
+ * name replaces the old one.
+ *
+ * Results:
+ * The return value is the name actually given to the interp.
+ * This will normally be the same as name, but if name was already
+ * in use for a Dde Server then a name of the form "name #2" will
+ * be chosen, with a high enough number to make the name unique.
+ *
+ * Side effects:
+ * Registration info is saved, thereby allowing the "send" command
+ * to be used later to invoke commands in the application. In
+ * addition, the "send" command is created in the application's
+ * interpreter. The registration will be removed automatically
+ * if the interpreter is deleted or the "send" command is removed.
+ *
+ *--------------------------------------------------------------
+ */
+
+static char *
+DdeSetServerName(interp, name)
+ Tcl_Interp *interp;
+ char *name; /* The name that will be used to
+ * refer to the interpreter in later
+ * "send" commands. Must be globally
+ * unique. */
+{
+ int suffix, offset;
+ RegisteredInterp *riPtr, *prevPtr;
+ Tcl_DString dString;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ /*
+ * See if the application is already registered; if so, remove its
+ * current name from the registry. The deletion of the command
+ * will take care of disposing of this entry.
+ */
+
+ for (riPtr = tsdPtr->interpListPtr, prevPtr = NULL; riPtr != NULL;
+ prevPtr = riPtr, riPtr = riPtr->nextPtr) {
+ if (riPtr->interp == interp) {
+ if (name != NULL) {
+ if (prevPtr == NULL) {
+ tsdPtr->interpListPtr = tsdPtr->interpListPtr->nextPtr;
+ } else {
+ prevPtr->nextPtr = riPtr->nextPtr;
+ }
+ break;
+ } else {
+ /*
+ * the name was NULL, so the caller is asking for
+ * the name of the current interp.
+ */
+
+ return riPtr->name;
+ }
+ }
+ }
+
+ if (name == NULL) {
+ /*
+ * the name was NULL, so the caller is asking for
+ * the name of the current interp, but it doesn't
+ * have a name.
+ */
+
+ return "";
+ }
+
+ /*
+ * Pick a name to use for the application. Use "name" if it's not
+ * already in use. Otherwise add a suffix such as " #2", trying
+ * larger and larger numbers until we eventually find one that is
+ * unique.
+ */
+
+ suffix = 1;
+ offset = 0;
+ Tcl_DStringInit(&dString);
+
+ /*
+ * We have found a unique name. Now add it to the registry.
+ */
+
+ riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp));
+ riPtr->interp = interp;
+ riPtr->name = ckalloc(strlen(name) + 1);
+ riPtr->nextPtr = tsdPtr->interpListPtr;
+ tsdPtr->interpListPtr = riPtr;
+ strcpy(riPtr->name, name);
+
+ Tcl_CreateObjCommand(interp, "dde", Tcl_DdeObjCmd,
+ (ClientData) riPtr, DeleteProc);
+ if (Tcl_IsSafe(interp)) {
+ Tcl_HideCommand(interp, "dde", "dde");
+ }
+ Tcl_DStringFree(&dString);
+
+ return riPtr->name;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * DeleteProc
+ *
+ * This procedure is called when the command "dde" is destroyed.
+ *
+ * Results:
+ * none
+ *
+ * Side effects:
+ * The interpreter given by riPtr is unregistered.
+ *
+ *--------------------------------------------------------------
+ */
+
+static void
+DeleteProc(clientData)
+ ClientData clientData; /* The interp we are deleting passed
+ * as ClientData. */
+{
+ RegisteredInterp *riPtr = (RegisteredInterp *) clientData;
+ RegisteredInterp *searchPtr, *prevPtr;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ for (searchPtr = tsdPtr->interpListPtr, prevPtr = NULL;
+ (searchPtr != NULL) && (searchPtr != riPtr);
+ prevPtr = searchPtr, searchPtr = searchPtr->nextPtr) {
+ /*
+ * Empty loop body.
+ */
+ }
+
+ if (searchPtr != NULL) {
+ if (prevPtr == NULL) {
+ tsdPtr->interpListPtr = tsdPtr->interpListPtr->nextPtr;
+ } else {
+ prevPtr->nextPtr = searchPtr->nextPtr;
+ }
+ }
+ ckfree(riPtr->name);
+ Tcl_EventuallyFree(clientData, TCL_DYNAMIC);
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * ExecuteRemoteObject --
+ *
+ * Takes the package delivered by DDE and executes it in
+ * the server's interpreter.
+ *
+ * Results:
+ * A list Tcl_Obj * that describes what happened. The first
+ * element is the numerical return code (TCL_ERROR, etc.).
+ * The second element is the result of the script. If the
+ * return result was TCL_ERROR, then the third element
+ * will be the value of the global "errorCode", and the
+ * fourth will be the value of the global "errorInfo".
+ * The return result will have a refCount of 0.
+ *
+ * Side effects:
+ * A Tcl script is run, which can cause all kinds of other
+ * things to happen.
+ *
+ *--------------------------------------------------------------
+ */
+
+static Tcl_Obj *
+ExecuteRemoteObject(
+ RegisteredInterp *riPtr, /* Info about this server. */
+ Tcl_Obj *ddeObjectPtr) /* The object to execute. */
+{
+ Tcl_Obj *errorObjPtr;
+ Tcl_Obj *returnPackagePtr;
+ int result;
+
+ result = Tcl_EvalObjEx(riPtr->interp, ddeObjectPtr, TCL_EVAL_GLOBAL);
+ returnPackagePtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+ Tcl_ListObjAppendElement(NULL, returnPackagePtr,
+ Tcl_NewIntObj(result));
+ Tcl_ListObjAppendElement(NULL, returnPackagePtr,
+ Tcl_GetObjResult(riPtr->interp));
+ if (result == TCL_ERROR) {
+ errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorCode", NULL,
+ TCL_GLOBAL_ONLY);
+ Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr);
+ errorObjPtr = Tcl_GetVar2Ex(riPtr->interp, "errorInfo", NULL,
+ TCL_GLOBAL_ONLY);
+ Tcl_ListObjAppendElement(NULL, returnPackagePtr, errorObjPtr);
+ }
+
+ return returnPackagePtr;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * DdeServerProc --
+ *
+ * Handles all transactions for this server. Can handle
+ * execute, request, and connect protocols. Dde will
+ * call this routine when a client attempts to run a dde
+ * command using this server.
+ *
+ * Results:
+ * A DDE Handle with the result of the dde command.
+ *
+ * Side effects:
+ * Depending on which command is executed, arbitrary
+ * Tcl scripts can be run.
+ *
+ *--------------------------------------------------------------
+ */
+
+static HDDEDATA CALLBACK
+DdeServerProc (
+ UINT uType, /* The type of DDE transaction we
+ * are performing. */
+ UINT uFmt, /* The format that data is sent or
+ * received. */
+ HCONV hConv, /* The conversation associated with the
+ * current transaction. */
+ HSZ ddeTopic, /* A string handle. Transaction-type
+ * dependent. */
+ HSZ ddeItem, /* A string handle. Transaction-type
+ * dependent. */
+ HDDEDATA hData, /* DDE data. Transaction-type dependent. */
+ DWORD dwData1, /* Transaction-dependent data. */
+ DWORD dwData2) /* Transaction-dependent data. */
+{
+ Tcl_DString dString;
+ int len;
+ char *utilString;
+ Tcl_Obj *ddeObjectPtr;
+ HDDEDATA ddeReturn = NULL;
+ RegisteredInterp *riPtr;
+ Conversation *convPtr, *prevConvPtr;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ switch(uType) {
+ case XTYP_CONNECT:
+
+ /*
+ * Dde is trying to initialize a conversation with us. Check
+ * and make sure we have a valid topic.
+ */
+
+ len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0);
+ Tcl_DStringInit(&dString);
+ Tcl_DStringSetLength(&dString, len);
+ utilString = Tcl_DStringValue(&dString);
+ DdeQueryString(ddeInstance, ddeTopic, utilString, len + 1,
+ CP_WINANSI);
+
+ for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
+ riPtr = riPtr->nextPtr) {
+ if (stricmp(utilString, riPtr->name) == 0) {
+ Tcl_DStringFree(&dString);
+ return (HDDEDATA) TRUE;
+ }
+ }
+
+ Tcl_DStringFree(&dString);
+ return (HDDEDATA) FALSE;
+
+ case XTYP_CONNECT_CONFIRM:
+
+ /*
+ * Dde has decided that we can connect, so it gives us a
+ * conversation handle. We need to keep track of it
+ * so we know which execution result to return in an
+ * XTYP_REQUEST.
+ */
+
+ len = DdeQueryString(ddeInstance, ddeTopic, NULL, 0, 0);
+ Tcl_DStringInit(&dString);
+ Tcl_DStringSetLength(&dString, len);
+ utilString = Tcl_DStringValue(&dString);
+ DdeQueryString(ddeInstance, ddeTopic, utilString, len + 1,
+ CP_WINANSI);
+ for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
+ riPtr = riPtr->nextPtr) {
+ if (stricmp(riPtr->name, utilString) == 0) {
+ convPtr = (Conversation *) ckalloc(sizeof(Conversation));
+ convPtr->nextPtr = tsdPtr->currentConversations;
+ convPtr->returnPackagePtr = NULL;
+ convPtr->hConv = hConv;
+ convPtr->riPtr = riPtr;
+ tsdPtr->currentConversations = convPtr;
+ break;
+ }
+ }
+ Tcl_DStringFree(&dString);
+ return (HDDEDATA) TRUE;
+
+ case XTYP_DISCONNECT:
+
+ /*
+ * The client has disconnected from our server. Forget this
+ * conversation.
+ */
+
+ for (convPtr = tsdPtr->currentConversations, prevConvPtr = NULL;
+ convPtr != NULL;
+ prevConvPtr = convPtr, convPtr = convPtr->nextPtr) {
+ if (hConv == convPtr->hConv) {
+ if (prevConvPtr == NULL) {
+ tsdPtr->currentConversations = convPtr->nextPtr;
+ } else {
+ prevConvPtr->nextPtr = convPtr->nextPtr;
+ }
+ if (convPtr->returnPackagePtr != NULL) {
+ Tcl_DecrRefCount(convPtr->returnPackagePtr);
+ }
+ ckfree((char *) convPtr);
+ break;
+ }
+ }
+ return (HDDEDATA) TRUE;
+
+ case XTYP_REQUEST:
+
+ /*
+ * This could be either a request for a value of a Tcl variable,
+ * or it could be the send command requesting the results of the
+ * last execute.
+ */
+
+ if (uFmt != CF_TEXT) {
+ return (HDDEDATA) FALSE;
+ }
+
+ ddeReturn = (HDDEDATA) FALSE;
+ for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
+ && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
+ /*
+ * Empty loop body.
+ */
+ }
+
+ if (convPtr != NULL) {
+ char *returnString;
+
+ len = DdeQueryString(ddeInstance, ddeItem, NULL, 0,
+ CP_WINANSI);
+ Tcl_DStringInit(&dString);
+ Tcl_DStringSetLength(&dString, len);
+ utilString = Tcl_DStringValue(&dString);
+ DdeQueryString(ddeInstance, ddeItem, utilString,
+ len + 1, CP_WINANSI);
+ if (stricmp(utilString, "$TCLEVAL$EXECUTE$RESULT") == 0) {
+ returnString =
+ Tcl_GetStringFromObj(convPtr->returnPackagePtr, &len);
+ ddeReturn = DdeCreateDataHandle(ddeInstance,
+ returnString, len+1, 0, ddeItem, CF_TEXT,
+ 0);
+ } else {
+ Tcl_Obj *variableObjPtr = Tcl_GetVar2Ex(
+ convPtr->riPtr->interp, utilString, NULL,
+ TCL_GLOBAL_ONLY);
+ if (variableObjPtr != NULL) {
+ returnString = Tcl_GetStringFromObj(variableObjPtr,
+ &len);
+ ddeReturn = DdeCreateDataHandle(ddeInstance,
+ returnString, len+1, 0, ddeItem, CF_TEXT, 0);
+ } else {
+ ddeReturn = NULL;
+ }
+ }
+ Tcl_DStringFree(&dString);
+ }
+ return ddeReturn;
+
+ case XTYP_EXECUTE: {
+
+ /*
+ * Execute this script. The results will be saved into
+ * a list object which will be retreived later. See
+ * ExecuteRemoteObject.
+ */
+
+ Tcl_Obj *returnPackagePtr;
+
+ for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
+ && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
+ /*
+ * Empty loop body.
+ */
+
+ }
+
+ if (convPtr == NULL) {
+ return (HDDEDATA) DDE_FNOTPROCESSED;
+ }
+
+ utilString = (char *) DdeAccessData(hData, &len);
+ ddeObjectPtr = Tcl_NewStringObj(utilString, -1);
+ Tcl_IncrRefCount(ddeObjectPtr);
+ DdeUnaccessData(hData);
+ if (convPtr->returnPackagePtr != NULL) {
+ Tcl_DecrRefCount(convPtr->returnPackagePtr);
+ }
+ convPtr->returnPackagePtr = NULL;
+ returnPackagePtr =
+ ExecuteRemoteObject(convPtr->riPtr, ddeObjectPtr);
+ for (convPtr = tsdPtr->currentConversations; (convPtr != NULL)
+ && (convPtr->hConv != hConv); convPtr = convPtr->nextPtr) {
+ /*
+ * Empty loop body.
+ */
+
+ }
+ if (convPtr != NULL) {
+ Tcl_IncrRefCount(returnPackagePtr);
+ convPtr->returnPackagePtr = returnPackagePtr;
+ }
+ Tcl_DecrRefCount(ddeObjectPtr);
+ if (returnPackagePtr == NULL) {
+ return (HDDEDATA) DDE_FNOTPROCESSED;
+ } else {
+ return (HDDEDATA) DDE_FACK;
+ }
+ }
+
+ case XTYP_WILDCONNECT: {
+
+ /*
+ * Dde wants a list of services and topics that we support.
+ */
+
+ HSZPAIR *returnPtr;
+ int i;
+ int numItems;
+
+ for (i = 0, riPtr = tsdPtr->interpListPtr; riPtr != NULL;
+ i++, riPtr = riPtr->nextPtr) {
+ /*
+ * Empty loop body.
+ */
+
+ }
+
+ numItems = i;
+ ddeReturn = DdeCreateDataHandle(ddeInstance, NULL,
+ (numItems + 1) * sizeof(HSZPAIR), 0, 0, 0, 0);
+ returnPtr = (HSZPAIR *) DdeAccessData(ddeReturn, &len);
+ for (i = 0, riPtr = tsdPtr->interpListPtr; i < numItems;
+ i++, riPtr = riPtr->nextPtr) {
+ returnPtr[i].hszSvc = DdeCreateStringHandle(
+ ddeInstance, "TclEval", CP_WINANSI);
+ returnPtr[i].hszTopic = DdeCreateStringHandle(
+ ddeInstance, riPtr->name, CP_WINANSI);
+ }
+ returnPtr[i].hszSvc = NULL;
+ returnPtr[i].hszTopic = NULL;
+ DdeUnaccessData(ddeReturn);
+ return ddeReturn;
+ }
+
+ }
+ return NULL;
+}
+
+
+/*
+ *--------------------------------------------------------------
+ *
+ * DdeExitProc --
+ *
+ * Gets rid of our DDE server when we go away.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The DDE server is deleted.
+ *
+ *--------------------------------------------------------------
+ */
+
+static void
+DdeExitProc(
+ ClientData clientData) /* Not used in this handler. */
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ DdeNameService(ddeInstance, NULL, 0, DNS_UNREGISTER);
+ DdeUninitialize(ddeInstance);
+ ddeInstance = 0;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * MakeDdeConnection --
+ *
+ * This procedure is a utility used to connect to a DDE
+ * server when given a server name and a topic name.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ *
+ * Side effects:
+ * Passes back a conversation through ddeConvPtr
+ *
+ *--------------------------------------------------------------
+ */
+
+static int
+MakeDdeConnection(
+ Tcl_Interp *interp, /* Used to report errors. */
+ char *name, /* The connection to use. */
+ HCONV *ddeConvPtr)
+{
+ HSZ ddeTopic, ddeService;
+ HCONV ddeConv;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ ddeService = DdeCreateStringHandle(ddeInstance, "TclEval", 0);
+ ddeTopic = DdeCreateStringHandle(ddeInstance, name, 0);
+
+ ddeConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
+ DdeFreeStringHandle(ddeInstance, ddeService);
+ DdeFreeStringHandle(ddeInstance, ddeTopic);
+
+ if (ddeConv == (HCONV) NULL) {
+ if (interp != NULL) {
+ Tcl_AppendResult(interp, "no registered server named \"",
+ name, "\"", (char *) NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ *ddeConvPtr = ddeConv;
+ return TCL_OK;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * SetDdeError --
+ *
+ * Sets the interp result to a cogent error message
+ * describing the last DDE error.
+ *
+ * Results:
+ * None.
+ *
+ *
+ * Side effects:
+ * The interp's result object is changed.
+ *
+ *--------------------------------------------------------------
+ */
+
+static void
+SetDdeError(
+ Tcl_Interp *interp) /* The interp to put the message in.*/
+{
+ Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
+ int err;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ err = DdeGetLastError(ddeInstance);
+ switch (err) {
+ case DMLERR_DATAACKTIMEOUT:
+ case DMLERR_EXECACKTIMEOUT:
+ case DMLERR_POKEACKTIMEOUT:
+ Tcl_SetStringObj(resultPtr,
+ "remote interpreter did not respond", -1);
+ break;
+
+ case DMLERR_BUSY:
+ Tcl_SetStringObj(resultPtr, "remote server is busy", -1);
+ break;
+
+ case DMLERR_NOTPROCESSED:
+ Tcl_SetStringObj(resultPtr,
+ "remote server cannot handle this command", -1);
+ break;
+
+ default:
+ Tcl_SetStringObj(resultPtr, "dde command failed", -1);
+ }
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Tcl_DdeObjCmd --
+ *
+ * This procedure is invoked to process the "dde" Tcl command.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *--------------------------------------------------------------
+ */
+
+int
+Tcl_DdeObjCmd(
+ ClientData clientData, /* Used only for deletion */
+ Tcl_Interp *interp, /* The interp we are sending from */
+ int objc, /* Number of arguments */
+ Tcl_Obj *CONST objv[]) /* The arguments */
+{
+ enum {
+ DDE_SERVERNAME,
+ DDE_EXECUTE,
+ DDE_REQUEST,
+ DDE_SERVICES,
+ DDE_EVAL
+ };
+
+ static char *ddeCommands[] = {"servername", "execute",
+ "request", "services", "eval",
+ (char *) NULL};
+ static char *ddeOptions[] = {"-async", (char *) NULL};
+ int index, argIndex;
+ int async = 0;
+ int result = TCL_OK;
+ HSZ ddeService = NULL;
+ HSZ ddeTopic = NULL;
+ HSZ ddeItem = NULL;
+ HDDEDATA ddeData = NULL;
+ HDDEDATA ddeItemData = NULL;
+ HCONV hConv;
+ HSZ ddeCookie = 0;
+ char *serviceName, *topicName, *itemString, *dataString;
+ char *string;
+ int firstArg, length, dataLength;
+ DWORD ddeResult;
+ HDDEDATA ddeReturn;
+ RegisteredInterp *riPtr;
+ Tcl_Interp *sendInterp;
+ Tcl_Obj *objPtr;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ /*
+ * Initialize DDE server/client
+ */
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "?-async? serviceName topicName value");
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetIndexFromObj(interp, objv[1], ddeCommands, "command", 0,
+ &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ switch (index) {
+ case DDE_SERVERNAME:
+ if ((objc != 3) && (objc != 2)) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "servername ?serverName?");
+ return TCL_ERROR;
+ }
+ firstArg = (objc - 1);
+ break;
+ case DDE_EXECUTE:
+ if ((objc < 5) || (objc > 6)) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "execute ?-async? serviceName topicName value");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(NULL, objv[2], ddeOptions, "option", 0,
+ &argIndex) != TCL_OK) {
+ if (objc != 5) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "execute ?-async? serviceName topicName value");
+ return TCL_ERROR;
+ }
+ async = 0;
+ firstArg = 2;
+ } else {
+ if (objc != 6) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "execute ?-async? serviceName topicName value");
+ return TCL_ERROR;
+ }
+ async = 1;
+ firstArg = 3;
+ }
+ break;
+ case DDE_REQUEST:
+ if (objc != 5) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "request serviceName topicName value");
+ return TCL_ERROR;
+ }
+ firstArg = 2;
+ break;
+ case DDE_SERVICES:
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "services serviceName topicName");
+ return TCL_ERROR;
+ }
+ firstArg = 2;
+ break;
+ case DDE_EVAL:
+ if (objc < 4) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "eval ?-async? serviceName args");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(NULL, objv[2], ddeOptions, "option", 0,
+ &argIndex) != TCL_OK) {
+ if (objc < 4) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "eval ?-async? serviceName args");
+ return TCL_ERROR;
+ }
+ async = 0;
+ firstArg = 2;
+ } else {
+ if (objc < 5) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "eval ?-async? serviceName args");
+ return TCL_ERROR;
+ }
+ async = 1;
+ firstArg = 3;
+ }
+ break;
+ }
+
+ if (firstArg != 1) {
+ serviceName = Tcl_GetStringFromObj(objv[firstArg], &length);
+ } else {
+ serviceName = NULL;
+ }
+
+ if (length == 0) {
+ serviceName = NULL;
+ } else if (index != DDE_SERVERNAME) {
+ ddeService = DdeCreateStringHandle(ddeInstance, serviceName,
+ CP_WINANSI);
+ }
+
+ if ((index != DDE_SERVERNAME) &&(index != DDE_EVAL)) {
+ topicName = Tcl_GetStringFromObj(objv[firstArg + 1], &length);
+ if (length == 0) {
+ topicName = NULL;
+ } else {
+ ddeTopic = DdeCreateStringHandle(ddeInstance,
+ topicName, CP_WINANSI);
+ }
+ }
+
+ switch (index) {
+ case DDE_SERVERNAME: {
+ serviceName = DdeSetServerName(interp, serviceName);
+ if (serviceName != NULL) {
+ Tcl_SetStringObj(Tcl_GetObjResult(interp),
+ serviceName, -1);
+ Initialize();
+ } else {
+ Tcl_ResetResult(interp);
+ }
+ break;
+ }
+ case DDE_EXECUTE: {
+ Initialize();
+ dataString = Tcl_GetStringFromObj(objv[firstArg + 2], &dataLength);
+ if (dataLength == 0) {
+ Tcl_SetStringObj(Tcl_GetObjResult(interp),
+ "cannot execute null data", -1);
+ result = TCL_ERROR;
+ break;
+ }
+ hConv = DdeConnect(ddeInstance, ddeService, ddeTopic,
+ NULL);
+
+ if (hConv == NULL) {
+ SetDdeError(interp);
+ result = TCL_ERROR;
+ break;
+ }
+
+ ddeData = DdeCreateDataHandle(ddeInstance, dataString,
+ dataLength+1, 0, 0, CF_TEXT, 0);
+ if (ddeData != NULL) {
+ if (async) {
+ DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF, hConv, 0,
+ CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
+ DdeAbandonTransaction(ddeInstance, hConv,
+ ddeResult);
+ } else {
+ ddeReturn = DdeClientTransaction((LPBYTE) ddeData, 0xFFFFFFFF,
+ hConv, 0, CF_TEXT, XTYP_EXECUTE, 30000, NULL);
+ if (ddeReturn == 0) {
+ SetDdeError(interp);
+ result = TCL_ERROR;
+ }
+ }
+ DdeFreeDataHandle(ddeData);
+ } else {
+ SetDdeError(interp);
+ result = TCL_ERROR;
+ }
+ DdeDisconnect(hConv);
+ break;
+ }
+ case DDE_REQUEST: {
+ Initialize();
+ itemString = Tcl_GetStringFromObj(objv[firstArg + 2], &length);
+ if (length == 0) {
+ Tcl_SetStringObj(Tcl_GetObjResult(interp),
+ "cannot request value of null data", -1);
+ return TCL_ERROR;
+ }
+ hConv = DdeConnect(ddeInstance, ddeService, ddeTopic,
+ NULL);
+
+ if (hConv == NULL) {
+ SetDdeError(interp);
+ result = TCL_ERROR;
+ } else {
+ Tcl_Obj *returnObjPtr;
+ ddeItem = DdeCreateStringHandle(ddeInstance,
+ itemString, CP_WINANSI);
+ if (ddeItem != NULL) {
+ ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem,
+ CF_TEXT, XTYP_REQUEST, 5000, NULL);
+ if (ddeData == NULL) {
+ SetDdeError(interp);
+ result = TCL_ERROR;
+ } else {
+ dataString = DdeAccessData(ddeData, &dataLength);
+ returnObjPtr = Tcl_NewStringObj(dataString, -1);
+ DdeUnaccessData(ddeData);
+ DdeFreeDataHandle(ddeData);
+ Tcl_SetObjResult(interp, returnObjPtr);
+ }
+ } else {
+ SetDdeError(interp);
+ result = TCL_ERROR;
+ }
+ DdeDisconnect(hConv);
+ }
+
+ break;
+ }
+ case DDE_SERVICES: {
+ HCONVLIST hConvList;
+ CONVINFO convInfo;
+ Tcl_Obj *convListObjPtr, *elementObjPtr;
+ Tcl_DString dString;
+ char *name;
+
+ Initialize();
+ convInfo.cb = sizeof(CONVINFO);
+ hConvList = DdeConnectList(ddeInstance, ddeService,
+ ddeTopic, 0, NULL);
+ hConv = 0;
+ convListObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+ Tcl_DStringInit(&dString);
+
+ while (hConv = DdeQueryNextServer(hConvList, hConv), hConv != 0) {
+ elementObjPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+ DdeQueryConvInfo(hConv, QID_SYNC, &convInfo);
+ length = DdeQueryString(ddeInstance,
+ convInfo.hszSvcPartner, NULL, 0, CP_WINANSI);
+ Tcl_DStringSetLength(&dString, length);
+ name = Tcl_DStringValue(&dString);
+ DdeQueryString(ddeInstance, convInfo.hszSvcPartner,
+ name, length + 1, CP_WINANSI);
+ Tcl_ListObjAppendElement(interp, elementObjPtr,
+ Tcl_NewStringObj(name, length));
+ length = DdeQueryString(ddeInstance, convInfo.hszTopic,
+ NULL, 0, CP_WINANSI);
+ Tcl_DStringSetLength(&dString, length);
+ name = Tcl_DStringValue(&dString);
+ DdeQueryString(ddeInstance, convInfo.hszTopic, name,
+ length + 1, CP_WINANSI);
+ Tcl_ListObjAppendElement(interp, elementObjPtr,
+ Tcl_NewStringObj(name, length));
+ Tcl_ListObjAppendElement(interp, convListObjPtr, elementObjPtr);
+ }
+ DdeDisconnectList(hConvList);
+ Tcl_SetObjResult(interp, convListObjPtr);
+ Tcl_DStringFree(&dString);
+ break;
+ }
+ case DDE_EVAL: {
+ Initialize();
+ objc -= (async + 3);
+ ((Tcl_Obj **) objv) += (async + 3);
+
+ /*
+ * See if the target interpreter is local. If so, execute
+ * the command directly without going through the DDE server.
+ * Don't exchange objects between interps. The target interp could
+ * compile an object, producing a bytecode structure that refers to
+ * other objects owned by the target interp. If the target interp
+ * is then deleted, the bytecode structure would be referring to
+ * deallocated objects.
+ */
+
+ for (riPtr = tsdPtr->interpListPtr; riPtr != NULL; riPtr
+ = riPtr->nextPtr) {
+ if (stricmp(serviceName, riPtr->name) == 0) {
+ break;
+ }
+ }
+
+ if (riPtr != NULL) {
+ /*
+ * This command is to a local interp. No need to go through
+ * the server.
+ */
+
+ Tcl_Preserve((ClientData) riPtr);
+ sendInterp = riPtr->interp;
+ Tcl_Preserve((ClientData) sendInterp);
+
+ /*
+ * Don't exchange objects between interps. The target interp would
+ * compile an object, producing a bytecode structure that refers to
+ * other objects owned by the target interp. If the target interp
+ * is then deleted, the bytecode structure would be referring to
+ * deallocated objects.
+ */
+
+ if (objc == 1) {
+ result = Tcl_EvalObjEx(sendInterp, objv[0], TCL_EVAL_GLOBAL);
+ } else {
+ objPtr = Tcl_ConcatObj(objc, objv);
+ Tcl_IncrRefCount(objPtr);
+ result = Tcl_EvalObjEx(sendInterp, objPtr, TCL_EVAL_GLOBAL);
+ Tcl_DecrRefCount(objPtr);
+ }
+ if (interp != sendInterp) {
+ if (result == TCL_ERROR) {
+ /*
+ * An error occurred, so transfer error information from the
+ * destination interpreter back to our interpreter.
+ */
+
+ Tcl_ResetResult(interp);
+ objPtr = Tcl_GetVar2Ex(sendInterp, "errorInfo", NULL,
+ TCL_GLOBAL_ONLY);
+ string = Tcl_GetStringFromObj(objPtr, &length);
+ Tcl_AddObjErrorInfo(interp, string, length);
+
+ objPtr = Tcl_GetVar2Ex(sendInterp, "errorCode", NULL,
+ TCL_GLOBAL_ONLY);
+ Tcl_SetObjErrorCode(interp, objPtr);
+ }
+ Tcl_SetObjResult(interp, Tcl_GetObjResult(sendInterp));
+ }
+ Tcl_Release((ClientData) riPtr);
+ Tcl_Release((ClientData) sendInterp);
+ } else {
+ /*
+ * This is a non-local request. Send the script to the server and poll
+ * it for a result.
+ */
+
+ if (MakeDdeConnection(interp, serviceName, &hConv) != TCL_OK) {
+ goto error;
+ }
+
+ objPtr = Tcl_ConcatObj(objc, objv);
+ string = Tcl_GetStringFromObj(objPtr, &length);
+ ddeItemData = DdeCreateDataHandle(ddeInstance, string, length+1, 0, 0,
+ CF_TEXT, 0);
+
+ if (async) {
+ ddeData = DdeClientTransaction((LPBYTE) ddeItemData, 0xFFFFFFFF, hConv, 0,
+ CF_TEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
+ DdeAbandonTransaction(ddeInstance, hConv, ddeResult);
+ } else {
+ ddeData = DdeClientTransaction((LPBYTE) ddeItemData, 0xFFFFFFFF, hConv, 0,
+ CF_TEXT, XTYP_EXECUTE, 30000, NULL);
+ if (ddeData != 0) {
+
+ ddeCookie = DdeCreateStringHandle(ddeInstance,
+ "$TCLEVAL$EXECUTE$RESULT", CP_WINANSI);
+ ddeData = DdeClientTransaction(NULL, 0, hConv, ddeCookie,
+ CF_TEXT, XTYP_REQUEST, 30000, NULL);
+ }
+ }
+
+
+ Tcl_DecrRefCount(objPtr);
+
+ if (ddeData == 0) {
+ SetDdeError(interp);
+ DdeFreeDataHandle(ddeItemData);
+ DdeDisconnect(hConv);
+ goto error;
+ }
+
+ if (async == 0) {
+ Tcl_Obj *resultPtr;
+
+ /*
+ * The return handle has a two or four element list in it. The first
+ * element is the return code (TCL_OK, TCL_ERROR, etc.). The
+ * second is the result of the script. If the return code is TCL_ERROR,
+ * then the third element is the value of the variable "errorCode",
+ * and the fourth is the value of the variable "errorInfo".
+ */
+
+ resultPtr = Tcl_NewObj();
+ length = DdeGetData(ddeData, NULL, 0, 0);
+ Tcl_SetObjLength(resultPtr, length);
+ string = Tcl_GetString(resultPtr);
+ DdeGetData(ddeData, string, length, 0);
+ Tcl_SetObjLength(resultPtr, strlen(string));
+
+ if (Tcl_ListObjIndex(NULL, resultPtr, 0, &objPtr) != TCL_OK) {
+ Tcl_DecrRefCount(resultPtr);
+ goto error;
+ }
+ if (Tcl_GetIntFromObj(NULL, objPtr, &result) != TCL_OK) {
+ Tcl_DecrRefCount(resultPtr);
+ goto error;
+ }
+ if (result == TCL_ERROR) {
+ Tcl_ResetResult(interp);
+
+ if (Tcl_ListObjIndex(NULL, resultPtr, 3, &objPtr) != TCL_OK) {
+ Tcl_DecrRefCount(resultPtr);
+ goto error;
+ }
+ length = -1;
+ string = Tcl_GetStringFromObj(objPtr, &length);
+ Tcl_AddObjErrorInfo(interp, string, length);
+
+ Tcl_ListObjIndex(NULL, resultPtr, 2, &objPtr);
+ Tcl_SetObjErrorCode(interp, objPtr);
+ }
+ if (Tcl_ListObjIndex(NULL, resultPtr, 1, &objPtr) != TCL_OK) {
+ Tcl_DecrRefCount(resultPtr);
+ goto error;
+ }
+ Tcl_SetObjResult(interp, objPtr);
+ Tcl_DecrRefCount(resultPtr);
+ }
+ }
+ }
+ }
+ if (ddeCookie != NULL) {
+ DdeFreeStringHandle(ddeInstance, ddeCookie);
+ }
+ if (ddeItem != NULL) {
+ DdeFreeStringHandle(ddeInstance, ddeItem);
+ }
+ if (ddeItemData != NULL) {
+ DdeFreeDataHandle(ddeItemData);
+ }
+ if (ddeData != NULL) {
+ DdeFreeDataHandle(ddeData);
+ }
+ if (hConv != NULL) {
+ DdeDisconnect(hConv);
+ }
+ return result;
+
+ error:
+ Tcl_SetStringObj(Tcl_GetObjResult(interp),
+ "invalid data returned from server", -1);
+ if (ddeCookie != NULL) {
+ DdeFreeStringHandle(ddeInstance, ddeCookie);
+ }
+ if (ddeItem != NULL) {
+ DdeFreeStringHandle(ddeInstance, ddeItem);
+ }
+ if (ddeItemData != NULL) {
+ DdeFreeDataHandle(ddeItemData);
+ }
+ if (ddeData != NULL) {
+ DdeFreeDataHandle(ddeData);
+ }
+ if (hConv != NULL) {
+ DdeDisconnect(hConv);
+ }
+ return TCL_ERROR;
+}
diff --git a/win/tclWinError.c b/win/tclWinError.c
index b50732b..7786334 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.
*
- * RCS: @(#) $Id: tclWinError.c,v 1.2 1998/09/14 18:40:19 stanton Exp $
+ * RCS: @(#) $Id: tclWinError.c,v 1.3 1999/04/16 00:48:08 stanton Exp $
*/
-#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 8eb836f..81f4608 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.
*
- * RCS: @(#) $Id: tclWinFCmd.c,v 1.2 1998/09/14 18:40:19 stanton Exp $
+ * RCS: @(#) $Id: tclWinFCmd.c,v 1.3 1999/04/16 00:48:08 stanton Exp $
*/
#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 = Tcl_UniCharLen(data.w.cFileName) * sizeof(WCHAR);
+ } else {
+ if ((strcmp(data.a.cFileName, ".") == 0)
+ || (strcmp(data.a.cFileName, "..") == 0)) {
+ continue;
}
+ nativeName = (TCHAR *) data.a.cFileName;
+ len = strlen(data.a.cFileName);
+ }
- /*
- * 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 b43ff51..e7dce3f 100644
--- a/win/tclWinFile.c
+++ b/win/tclWinFile.c
@@ -6,58 +6,68 @@
* 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.
*
- * RCS: @(#) $Id: tclWinFile.c,v 1.4 1999/03/10 05:52:53 stanton Exp $
+ * RCS: @(#) $Id: tclWinFile.c,v 1.5 1999/04/16 00:48:08 stanton Exp $
*/
#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);
/*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*
- * Tcl_FindExecutable --
+ * TclpFindExecutable --
*
* This procedure computes the absolute path name of the current
* application, given its argv[0] value.
*
* Results:
- * None.
+ * A dirty UTF string that is the path to the executable. At this
+ * point we may not know the system encoding. Convert the native
+ * string value to UTF using the default encoding. The assumption
+ * is that we will still be able to parse the path given the path
+ * name contains ASCII string and '/' chars do not conflict with
+ * other UTF chars.
*
* Side effects:
- * The variable tclExecutableName gets filled in with the file
+ * The variable tclNativeExecutableName gets filled in with the file
* name for the application, if we figured it out. If we couldn't
- * figure it out, Tcl_FindExecutable is set to NULL.
+ * figure it out, tclNativeExecutableName is set to NULL.
*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
*/
-void
-Tcl_FindExecutable(argv0)
- char *argv0; /* The value of the application's argv[0]. */
+char *
+TclpFindExecutable(argv0)
+ CONST char *argv0; /* The value of the application's argv[0]
+ * (native). */
{
- Tcl_DString buffer;
- int length;
-
- Tcl_DStringInit(&buffer);
+ Tcl_DString ds;
+ WCHAR wName[MAX_PATH];
- if (tclExecutableName != NULL) {
- ckfree(tclExecutableName);
- tclExecutableName = NULL;
+ if (argv0 == NULL) {
+ return NULL;
+ }
+ if (tclNativeExecutableName != NULL) {
+ return tclNativeExecutableName;
}
/*
@@ -65,26 +75,28 @@ 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);
+
+ tclNativeExecutableName = ckalloc((unsigned) (Tcl_DStringLength(&ds) + 1));
+ strcpy(tclNativeExecutableName, Tcl_DStringValue(&ds));
+ Tcl_DStringFree(&ds);
+
+ TclWinNoBackslash(tclNativeExecutableName);
+ return tclNativeExecutableName;
}
/*
*----------------------------------------------------------------------
*
- * 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,25 +107,27 @@ 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. */
char *pattern; /* Pattern to match against. */
char *tail; /* Pointer to end of pattern. Tail must
- * point to a location in pattern. */
+ * point to a location in pattern. Must not
+ * point to a static string. */
{
- 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 +135,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 +178,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,42 +272,41 @@ 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
* the file name to lower case for comparison purposes. Note that we
* are ignoring the case sensitivity flag because Windows doesn't honor
* case even if the volume is case sensitive. If the volume also
- * doesn't preserve case, then we return the lower case form of the
- * name, otherwise we return the system form.
+ * doesn't preserve case, then we previously returned the lower case
+ * form of the name. This didn't seem quite right since there are
+ * non-case-preserving volumes that actually return mixed case. So now
+ * we are returning exactly what we get from the system.
*/
- 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;
- }
- }
+ Tcl_UtfToLower(name);
+ nativeMatchResult = NULL;
- if (matchResult == 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 +317,19 @@ 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);
+ 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 +337,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 = Tcl_UtfToUniCharDString(domain + 1, -1, &ds);
+ badDomain = (*netGetDCNameProc)(NULL, wName,
+ (LPBYTE *) &wDomain);
+ Tcl_DStringFree(&ds);
+ nameLen = domain - name;
+ }
+ if (badDomain == 0) {
+ Tcl_DStringInit(&ds);
+ wName = Tcl_UtfToUniCharDString(name, nameLen, &ds);
+ if ((*netUserGetInfoProc)(wDomain, wName, 1,
+ (LPBYTE *) &uiPtr) == 0) {
+ wHomeDir = uiPtr->usri1_home_dir;
+ if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) {
+ Tcl_UniCharToUtfDString(wHomeDir, lstrlenW(wHomeDir),
+ bufferPtr);
+ } else {
+ /*
+ * User exists but has no home dir. Return
+ * "{Windows Drive}:/users/default".
+ */
+
+ GetWindowsDirectoryW(buf, MAX_PATH);
+ Tcl_UniCharToUtfDString(buf, 2, bufferPtr);
+ Tcl_DStringAppend(bufferPtr, "/users/default", -1);
+ }
+ result = Tcl_DStringValue(bufferPtr);
+ (*netApiBufferFreeProc)((void *) uiPtr);
+ }
+ Tcl_DStringFree(&ds);
+ }
+ if (wDomain != NULL) {
+ (*netApiBufferFreeProc)((void *) wDomain);
+ }
+ }
+ FreeLibrary(netapiInst);
}
- if (!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
/*
*----------------------------------------------------------------------
*
- * TclpStat, TclpLstat --
+ * 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 +695,164 @@ TclWinResolveShortcut(bufferPtr)
*/
int
-TclpStat(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.
+ */
-#ifndef _MSC_VER
+ memset(&data, 0, sizeof(data));
+ data.a.dwFileAttributes = attr;
+ } else {
+ FindClose(handle);
+ }
+
+ (*tclWinProcs->getFullPathNameProc)(nativePath, MAX_PATH, nativeFullPath,
+ &nativePart);
+
+ Tcl_DStringFree(&ds);
+ fullPath = Tcl_WinTCharToUtf((TCHAR *) nativeFullPath, -1, &ds);
+
+ dev = -1;
+ if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) {
+ char *p;
+ DWORD dw;
+ TCHAR *nativeVol;
+ Tcl_DString volString;
+
+ p = strchr(fullPath + 2, '\\');
+ p = strchr(p + 1, '\\');
+ if (p == NULL) {
+ /*
+ * Add terminating backslash to fullpath or
+ * GetVolumeInformation() won't work.
+ */
+
+ fullPath = Tcl_DStringAppend(&ds, "\\", 1);
+ p = fullPath + Tcl_DStringLength(&ds);
+ } else {
+ p++;
+ }
+ nativeVol = Tcl_WinUtfToTChar(fullPath, p - fullPath, &volString);
+ dw = (DWORD) -1;
+ (*tclWinProcs->getVolumeInformationProc)(nativeVol, NULL, 0, &dw,
+ NULL, NULL, NULL, 0);
+ /*
+ * GetFullPathName() turns special devices like "NUL" into "\\.\NUL",
+ * but GetVolumeInformation() returns failure for "\\.\NUL". This
+ * will cause "NUL" to get a drive number of -1, which makes about
+ * as much sense as anything since the special devices don't live on
+ * any drive.
+ */
+
+ dev = dw;
+ Tcl_DStringFree(&volString);
+ } else if ((fullPath[0] != '\0') && (fullPath[1] == ':')) {
+ dev = Tcl_UniCharToLower(fullPath[0]) - 'a';
+ }
+ Tcl_DStringFree(&ds);
+
+ attr = data.a.dwFileAttributes;
+ mode = (attr & FILE_ATTRIBUTE_DIRECTORY) ? S_IFDIR | S_IEXEC : S_IFREG;
+ mode |= (attr & FILE_ATTRIBUTE_READONLY) ? S_IREAD : S_IREAD | S_IWRITE;
+ p = strrchr(path, '.');
+ if (p != NULL) {
+ if ((lstrcmpiA(p, ".exe") == 0)
+ || (lstrcmpiA(p, ".com") == 0)
+ || (lstrcmpiA(p, ".bat") == 0)
+ || (lstrcmpiA(p, ".pif") == 0)) {
+ mode |= S_IEXEC;
+ }
+ }
+
+ /*
+ * Propagate the S_IREAD, S_IWRITE, S_IEXEC bits to the group and
+ * other positions.
+ */
+
+ mode |= (mode & 0x0700) >> 3;
+ mode |= (mode & 0x0700) >> 6;
+
+ statPtr->st_dev = (dev_t) dev;
+ statPtr->st_ino = 0;
+ statPtr->st_mode = (unsigned short) mode;
+ statPtr->st_nlink = 1;
+ statPtr->st_uid = 0;
+ statPtr->st_gid = 0;
+ statPtr->st_rdev = (dev_t) dev;
+ statPtr->st_size = data.a.nFileSizeLow;
+ statPtr->st_atime = ToCTime(data.a.ftLastAccessTime);
+ statPtr->st_mtime = ToCTime(data.a.ftLastWriteTime);
+ statPtr->st_ctime = ToCTime(data.a.ftCreationTime);
+ return 0;
+}
+
+static time_t
+ToCTime(
+ FILETIME fileTime) /* UTC Time to convert to local time_t. */
+{
+ FILETIME localFileTime;
+ SYSTEMTIME systemTime;
+ struct tm tm;
+
+ if (FileTimeToLocalFileTime(&fileTime, &localFileTime) == 0) {
+ return 0;
+ }
+ if (FileTimeToSystemTime(&localFileTime, &systemTime) == 0) {
+ return 0;
+ }
+ tm.tm_sec = systemTime.wSecond;
+ tm.tm_min = systemTime.wMinute;
+ tm.tm_hour = systemTime.wHour;
+ tm.tm_mday = systemTime.wDay;
+ tm.tm_mon = systemTime.wMonth - 1;
+ tm.tm_year = systemTime.wYear - 1900;
+ tm.tm_wday = 0;
+ tm.tm_yday = 0;
+ tm.tm_isdst = -1;
+
+ return mktime(&tm);
+}
+
+#if 0
/*
* Borland's stat doesn't take into account localtime.
@@ -582,92 +875,82 @@ TclpStat(path, buf)
#endif
- return result;
-}
-
+
+#if 0
/*
- *---------------------------------------------------------------------------
- *
- * TclpAccess --
+ *-------------------------------------------------------------------------
*
- * 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
-TclpAccess(
- 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;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclGetUserHome --
- *
- * This function takes the passed in user name and finds the
- * corresponding home directory specified in the password file.
- *
- * Results:
- * On Windows we always return a NULL.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-char *
-TclGetUserHome(
- char *name, /* User name to use to find home directory. */
- Tcl_DString *bufferPtr) /* May be used to hold result. Must not hold
- * anything at the time of the call, and need
- * not even be initialized. */
-{
- return NULL;
+ return 0;
}
+#endif
diff --git a/win/tclWinInit.c b/win/tclWinInit.c
index 2a470df..7f03f2c 100644
--- a/win/tclWinInit.c
+++ b/win/tclWinInit.c
@@ -3,16 +3,16 @@
*
* Contains the Windows-specific interpreter initialization functions.
*
- * Copyright (c) 1994-1996 Sun Microsystems, Inc.
+ * Copyright (c) 1994-1997 Sun Microsystems, Inc.
+ * Copyright (c) 1998-1999 by Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclWinInit.c,v 1.13 1999/03/11 00:19:24 stanton Exp $
+ * RCS: @(#) $Id: tclWinInit.c,v 1.14 1999/04/16 00:48:08 stanton Exp $
*/
-#include "tclInt.h"
-#include "tclPort.h"
+#include "tclWinInt.h"
#include <winreg.h>
#include <winnt.h>
#include <winbase.h>
@@ -75,159 +75,440 @@ static char* processors[NUMPROCESSORS] = {
};
/*
- * The Init script, tclPreInitScript variable, and the routine
- * TclSetPreInitScript (common to Windows and Unix platforms) are defined
- * in generic/tclInitScript.h
+ * Thread id used for asynchronous notification from signal handlers.
+ */
+
+static DWORD mainThreadId;
+
+/*
+ * The Init script (common to Windows and Unix platforms) is
+ * defined in tkInitScript.h
*/
#include "tclInitScript.h"
+static void AppendEnvironment(Tcl_Obj *listPtr, CONST char *lib);
+static void AppendDllPath(Tcl_Obj *listPtr, HMODULE hModule,
+ CONST char *lib);
+static void AppendRegistry(Tcl_Obj *listPtr, CONST char *lib);
+static int ToUtf(CONST WCHAR *wSrc, char *dst);
+
/*
- * Thread id used for asynchronous notification from signal handlers.
+ *---------------------------------------------------------------------------
+ *
+ * TclpInitPlatform --
+ *
+ * Initialize all the platform-dependant things like signals and
+ * floating-point error handling.
+ *
+ * Called at process initialization time.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
*/
-static DWORD threadId;
+void
+TclpInitPlatform()
+{
+ tclPlatform = TCL_PLATFORM_WINDOWS;
+
+ /*
+ * The following code stops Windows 3.X and Windows NT 3.51 from
+ * automatically putting up Sharing Violation dialogs, e.g, when
+ * someone tries to access a file that is locked or a drive with no
+ * disk in it. Tcl already returns the appropriate error to the
+ * caller, and they can decide to put up their own dialog in response
+ * to that failure.
+ *
+ * Under 95 and NT 4.0, this is a NOOP because the system doesn't
+ * automatically put up dialogs when the above operations fail.
+ */
+
+ SetErrorMode(SetErrorMode(0) | SEM_FAILCRITICALERRORS);
+
+ /*
+ * Save the id of the first thread to intialize the Tcl library. This
+ * thread will be used to handle notifications from async event
+ * procedures. This is not strictly correct. A better solution involves
+ * using a designated "main" notifier that is kept up to date as threads
+ * come and go.
+ */
+ mainThreadId = GetCurrentThreadId();
+}
/*
- *----------------------------------------------------------------------
+ *---------------------------------------------------------------------------
+ *
+ * TclpInitLibraryPath --
+ *
+ * Initialize the library path at startup.
*
- * TclPlatformInit --
+ * 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.
*
- * 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;
+TclpInitLibraryPath(path)
+ CONST char *path; /* Potentially dirty UTF string that is */
+ /* the path to the executable name. */
{
- char *p;
- char buffer[13];
+#define LIBRARY_SIZE 32
+ Tcl_Obj *pathPtr, *objPtr;
+ char *str;
Tcl_DString ds;
- OSVERSIONINFO osInfo;
- SYSTEM_INFO sysInfo;
- int isWin32s; /* True if we are running under Win32s. */
- OemId *oemId;
- HKEY key;
- DWORD size, result, type;
-
- tclPlatform = TCL_PLATFORM_WINDOWS;
+ int pathc;
+ char **pathv;
+ char installLib[LIBRARY_SIZE], developLib[LIBRARY_SIZE];
Tcl_DStringInit(&ds);
+ pathPtr = Tcl_NewObj();
/*
- * Find out what kind of system we are running on.
+ * Initialize the substrings used when locating an executable. The
+ * installLib variable computes the path as though the executable
+ * is installed. The developLib computes the path as though the
+ * executable is run from a develpment directory.
*/
- osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFO);
- GetVersionEx(&osInfo);
-
- isWin32s = (osInfo.dwPlatformId == VER_PLATFORM_WIN32s);
+ sprintf(installLib, "lib/tcl%s", TCL_VERSION);
+ sprintf(developLib, "../tcl%s/library",
+ ((TCL_RELEASE_LEVEL < 2) ? TCL_PATCH_LEVEL : TCL_VERSION));
/*
- * Since Win32s doesn't support GetSystemInfo, we use a default value.
+ * Look for the library relative to default encoding dir.
*/
- oemId = (OemId *) &sysInfo;
- if (!isWin32s) {
- GetSystemInfo(&sysInfo);
- } else {
- oemId->wProcessorArchitecture = PROCESSOR_ARCHITECTURE_INTEL;
+ str = Tcl_GetDefaultEncodingDir();
+ if ((str != NULL) && (str[0] != '\0')) {
+ objPtr = Tcl_NewStringObj(str, -1);
+ Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
}
/*
- * Initialize the tcl_library variable from the registry.
+ * Look for the library relative to the TCL_LIBRARY env variable.
+ * If the last dirname in the TCL_LIBRARY path does not match the
+ * last dirname in the installLib variable, use the last dir name
+ * of installLib in addition to the orginal TCL_LIBRARY path.
*/
- Tcl_SetVar(interp, "tclDefaultLibrary", "", TCL_GLOBAL_ONLY);
- if (!isWin32s) {
- result = RegOpenKeyEx(HKEY_LOCAL_MACHINE, TCL_REGISTRY_KEY, 0,
- KEY_READ, &key);
+ AppendEnvironment(pathPtr, installLib);
+
+ /*
+ * Look for the library relative to the DLL. Only use the installLib
+ * because in practice, the DLL is always installed.
+ */
+
+ AppendDllPath(pathPtr, TclWinGetTclInstance(), installLib);
+
+ /*
+ * Look for the library relative to the executable. Use both the
+ * installLib and developLib because we cannot determine if this
+ * is installed or not.
+ */
+
+ if (path != NULL) {
+ Tcl_SplitPath(path, &pathc, &pathv);
+ if (pathc > 1) {
+ pathv[pathc - 2] = installLib;
+ path = Tcl_JoinPath(pathc - 1, pathv, &ds);
+ objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
+ Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
+ Tcl_DStringFree(&ds);
+ }
+ if (pathc > 2) {
+ pathv[pathc - 3] = developLib;
+ path = Tcl_JoinPath(pathc - 2, pathv, &ds);
+ objPtr = Tcl_NewStringObj(path, Tcl_DStringLength(&ds));
+ Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
+ Tcl_DStringFree(&ds);
+ }
+ ckfree((char *) pathv);
+ }
+
+ TclSetLibraryPath(pathPtr);
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * AppendEnvironment --
+ *
+ * Append the value of the TCL_LIBRARY environment variable onto the
+ * path pointer. If the env variable points to another version of
+ * tcl (e.g. "tcl7.6") also append the path to this version (e.g.,
+ * "tcl7.6/../tcl8.1")
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static void
+AppendEnvironment(
+ Tcl_Obj *pathPtr,
+ CONST char *lib)
+{
+ int pathc;
+ WCHAR wBuf[MAX_PATH];
+ char buf[MAX_PATH * TCL_UTF_MAX];
+ Tcl_Obj *objPtr;
+ char *str;
+ Tcl_DString ds;
+ char **pathv;
+
+ /*
+ * The "L" preceeding the TCL_LIBRARY string is used to tell VC++
+ * that this is a unicode string.
+ */
+
+ if (GetEnvironmentVariableW(L"TCL_LIBRARY", wBuf, MAX_PATH) == 0) {
+ buf[0] = '\0';
+ GetEnvironmentVariableA("TCL_LIBRARY", buf, MAX_PATH);
} else {
- result = RegOpenKeyEx(HKEY_CLASSES_ROOT, TCL_REGISTRY_KEY, 0,
- KEY_READ, &key);
+ ToUtf(wBuf, buf);
}
- if (result == ERROR_SUCCESS) {
- if (RegQueryValueEx(key, "", NULL, NULL, NULL, &size)
- == ERROR_SUCCESS) {
- char *argv[3];
- Tcl_DStringSetLength(&ds, size);
- RegQueryValueEx(key, "", NULL, NULL,
- (LPBYTE) Tcl_DStringValue(&ds), &size);
- Tcl_SetVar(interp, "tclDefaultLibrary", Tcl_DStringValue(&ds),
- TCL_GLOBAL_ONLY);
- argv[0] = Tcl_GetVar(interp, "tclDefaultLibrary", TCL_GLOBAL_ONLY);
- argv[1] = "lib/tcl" TCL_VERSION;
- argv[2] = NULL;
- Tcl_DStringSetLength(&ds, 0);
- Tcl_SetVar(interp, "tclDefaultLibrary",
- Tcl_JoinPath(2, argv, &ds), TCL_GLOBAL_ONLY);
- }
- if ((RegQueryValueEx(key, "PkgPath", NULL, &type, NULL, &size)
- == ERROR_SUCCESS) && (type == REG_MULTI_SZ)) {
- char **argv;
- int argc;
+ if (buf[0] != '\0') {
+ objPtr = Tcl_NewStringObj(buf, -1);
+ Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
+
+ TclWinNoBackslash(buf);
+ Tcl_SplitPath(buf, &pathc, &pathv);
+
+ /*
+ * The lstrcmpi() will work even if pathv[pathc - 1] is random
+ * UTF-8 chars because I know lib is ascii.
+ */
+
+ if ((pathc > 0) && (lstrcmpiA(lib + 4, pathv[pathc - 1]) != 0)) {
/*
- * PkgPath is stored as an array of null terminated strings
- * terminated by two null characters. First count the number
- * of strings, then allocate an argv array so we can construct
- * a valid list.
+ * TCL_LIBRARY is set but refers to a different tcl
+ * installation than the current version. Try fiddling with the
+ * specified directory to make it refer to this installation by
+ * removing the old "tclX.Y" and substituting the current
+ * version string.
*/
+
+ pathv[pathc - 1] = (char *) (lib + 4);
+ Tcl_DStringInit(&ds);
+ str = Tcl_JoinPath(pathc, pathv, &ds);
+ objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&ds));
+ Tcl_DStringFree(&ds);
+ } else {
+ objPtr = Tcl_NewStringObj(buf, -1);
+ }
+ Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
+ ckfree((char *) pathv);
+ }
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * AppendDllPath --
+ *
+ * Append a path onto the path pointer that tries to locate the Tcl
+ * library relative to the location of the Tcl DLL.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
- Tcl_DStringSetLength(&ds, size);
- RegQueryValueEx(key, "PkgPath", NULL, NULL,
- (LPBYTE)Tcl_DStringValue(&ds), &size);
- argc = 0;
- p = Tcl_DStringValue(&ds);
- do {
- if (*p) {
- argc++;
- }
- p += strlen(p) + 1;
- } while (*p);
-
- argv = (char **) ckalloc((sizeof(char *) * argc) + 1);
- argc = 0;
- p = Tcl_DStringValue(&ds);
- do {
- if (*p) {
- argv[argc++] = p;
- while (*p) {
- if (*p == '\\') {
- *p = '/';
- }
- p++;
- }
- }
- p++;
- } while (*p);
+static void
+AppendDllPath(
+ Tcl_Obj *pathPtr,
+ HMODULE hModule,
+ CONST char *lib)
+{
+ WCHAR wName[MAX_PATH + LIBRARY_SIZE];
+ char name[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX];
- p = Tcl_Merge(argc, argv);
- Tcl_SetVar(interp, "tcl_pkgPath", p, TCL_GLOBAL_ONLY);
- ckfree(p);
- ckfree((char*) argv);
- } else {
- char *argv[3];
- argv[0] = Tcl_GetVar(interp, "tclDefaultLibrary", TCL_GLOBAL_ONLY);
- argv[1] = "..";
- argv[2] = NULL;
- Tcl_DStringSetLength(&ds, 0);
- Tcl_SetVar(interp, "tcl_pkgPath", Tcl_JoinPath(2, argv, &ds),
- TCL_GLOBAL_ONLY|TCL_LIST_ELEMENT);
+ if (GetModuleFileNameW(hModule, wName, MAX_PATH) == 0) {
+ GetModuleFileNameA(hModule, name, MAX_PATH);
+ } else {
+ ToUtf(wName, name);
+ }
+ if (lib != NULL) {
+ char *end, *p;
+
+ end = strrchr(name, '\\');
+ *end = '\0';
+ p = strrchr(name, '\\');
+ if (p != NULL) {
+ end = p;
}
+ *end = '\\';
+ strcpy(end + 1, lib);
+ }
+ TclWinNoBackslash(name);
+ Tcl_ListObjAppendElement(NULL, pathPtr, Tcl_NewStringObj(name, -1));
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * ToUtf --
+ *
+ * Convert a char string to a UTF string.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static int
+ToUtf(
+ CONST WCHAR *wSrc,
+ char *dst)
+{
+ char *start;
+
+ start = dst;
+ while (*wSrc != '\0') {
+ dst += Tcl_UniCharToUtf(*wSrc, dst);
+ wSrc++;
+ }
+ *dst = '\0';
+ return dst - start;
+}
+
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclpSetInitialEncodings --
+ *
+ * Based on the locale, determine the encoding of the operating
+ * system and the default encoding for newly opened files.
+ *
+ * Called at process initialization time.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The Tcl library path is converted from native encoding to UTF-8.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+void
+TclpSetInitialEncodings()
+{
+ CONST char *encoding;
+ char buf[4 + TCL_INTEGER_SPACE];
+ int platformId;
+ Tcl_Obj *pathPtr;
+
+ platformId = TclWinGetPlatformId();
+
+ TclWinSetInterfaces(platformId == VER_PLATFORM_WIN32_NT);
+
+ wsprintfA(buf, "cp%d", GetACP());
+ Tcl_SetSystemEncoding(NULL, buf);
+
+ if (platformId != VER_PLATFORM_WIN32_NT) {
+ pathPtr = TclGetLibraryPath();
+ if (pathPtr != NULL) {
+ int i, objc;
+ Tcl_Obj **objv;
+
+ objc = 0;
+ Tcl_ListObjGetElements(NULL, pathPtr, &objc, &objv);
+ for (i = 0; i < objc; i++) {
+ int length;
+ char *string;
+ Tcl_DString ds;
+
+ string = Tcl_GetStringFromObj(objv[i], &length);
+ Tcl_ExternalToUtfDString(NULL, string, length, &ds);
+ Tcl_SetStringObj(objv[i], Tcl_DStringValue(&ds),
+ Tcl_DStringLength(&ds));
+ Tcl_DStringFree(&ds);
+ }
+ }
+ }
+
+ /*
+ * Keep this encoding preloaded. The IO package uses it for gets on a
+ * binary channel.
+ */
+
+ encoding = "iso8859-1";
+ Tcl_GetEncoding(NULL, encoding);
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclpSetVariables --
+ *
+ * Performs platform-specific interpreter initialization related to
+ * the tcl_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;
+ Tcl_DString ds;
+
+ 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 {
- Tcl_SetVar(interp, "tcl_pkgPath", "", TCL_GLOBAL_ONLY);
+ GetSystemInfo(&sysInfo);
}
/*
@@ -240,7 +521,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",
@@ -265,16 +546,16 @@ TclPlatformInit(interp)
* environment variables, if necessary.
*/
- p = Tcl_GetVar2(interp, "env", "HOME", TCL_GLOBAL_ONLY);
- if (p == NULL) {
- Tcl_DStringSetLength(&ds, 0);
- p = Tcl_GetVar2(interp, "env", "HOMEDRIVE", TCL_GLOBAL_ONLY);
- if (p != NULL) {
- Tcl_DStringAppend(&ds, p, -1);
+ Tcl_DStringInit(&ds);
+ ptr = Tcl_GetVar2(interp, "env", "HOME", TCL_GLOBAL_ONLY);
+ if (ptr == NULL) {
+ ptr = Tcl_GetVar2(interp, "env", "HOMEDRIVE", TCL_GLOBAL_ONLY);
+ if (ptr != NULL) {
+ Tcl_DStringAppend(&ds, ptr, -1);
}
- p = Tcl_GetVar2(interp, "env", "HOMEPATH", TCL_GLOBAL_ONLY);
- if (p != NULL) {
- Tcl_DStringAppend(&ds, p, -1);
+ ptr = Tcl_GetVar2(interp, "env", "HOMEPATH", TCL_GLOBAL_ONLY);
+ if (ptr != NULL) {
+ Tcl_DStringAppend(&ds, ptr, -1);
}
if (Tcl_DStringLength(&ds) > 0) {
Tcl_SetVar2(interp, "env", "HOME", Tcl_DStringValue(&ds),
@@ -284,14 +565,98 @@ TclPlatformInit(interp)
}
}
+ Tcl_DStringSetLength(&ds, 100);
+ if (GetUserName(Tcl_DStringValue(&ds), &Tcl_DStringLength(&ds)) != 0) {
+ Tcl_SetVar2(interp, "tcl_platform", "user", Tcl_DStringValue(&ds),
+ TCL_GLOBAL_ONLY);
+ } else {
+ Tcl_SetVar2(interp, "tcl_platform", "user", "", TCL_GLOBAL_ONLY);
+ }
Tcl_DStringFree(&ds);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpFindVariable --
+ *
+ * Locate the entry in environ for a given name. On Unix this
+ * routine is case sensetive, on Windows this matches mioxed case.
+ *
+ * Results:
+ * The return value is the index in environ of an entry with the
+ * name "name", or -1 if there is no such entry. The integer at
+ * *lengthPtr is filled in with the length of name (if a matching
+ * entry is found) or the length of the environ array (if no matching
+ * entry is found).
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclpFindVariable(name, lengthPtr)
+ CONST char *name; /* Name of desired environment variable
+ * (UTF-8). */
+ int *lengthPtr; /* Used to return length of name (for
+ * successful searches) or number of non-NULL
+ * entries in environ (for unsuccessful
+ * searches). */
+{
+ int i, length, result = -1;
+ register CONST char *env, *p1, *p2;
+ char *envUpper, *nameUpper;
+ Tcl_DString envString;
/*
- * Save the current thread id so an async signal handler can poke
- * the right thread using TclpAyncMark.
+ * Convert the name to all upper case for the case insensitive
+ * comparison.
*/
- threadId = GetCurrentThreadId();
+ length = strlen(name);
+ nameUpper = (char *) ckalloc((unsigned) length+1);
+ memcpy((VOID *) nameUpper, (VOID *) name, (size_t) length+1);
+ Tcl_UtfToUpper(nameUpper);
+
+ Tcl_DStringInit(&envString);
+ for (i = 0, env = environ[i]; env != NULL; i++, env = environ[i]) {
+ /*
+ * Chop the env string off after the equal sign, then Convert
+ * the name to all upper case, so we do not have to convert
+ * all the characters after the equal sign.
+ */
+
+ envUpper = Tcl_ExternalToUtfDString(NULL, env, -1, &envString);
+ p1 = strchr(envUpper, '=');
+ if (p1 == NULL) {
+ continue;
+ }
+ length = p1 - envUpper;
+ Tcl_DStringSetLength(&envString, length+1);
+ Tcl_UtfToUpper(envUpper);
+
+ p1 = envUpper;
+ p2 = nameUpper;
+ for (; *p2 == *p1; p1++, p2++) {
+ /* NULL loop body. */
+ }
+ if ((*p1 == '=') && (*p2 == '\0')) {
+ *lengthPtr = length;
+ result = i;
+ goto done;
+ }
+
+ Tcl_DStringFree(&envString);
+ }
+
+ *lengthPtr = i;
+
+ done:
+ Tcl_DStringFree(&envString);
+ ckfree(nameUpper);
+ return result;
}
/*
@@ -304,8 +669,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.
@@ -317,35 +682,20 @@ int
Tcl_Init(interp)
Tcl_Interp *interp; /* Interpreter to initialize. */
{
+ Tcl_Obj *pathPtr;
+
if (tclPreInitScript != NULL) {
if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) {
return (TCL_ERROR);
};
}
- return(Tcl_Eval(interp, initScript));
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclWinGetPlatform --
- *
- * This is a kludge that allows the test library to get access
- * the internal tclPlatform variable.
- *
- * Results:
- * Returns a pointer to the tclPlatform variable.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-TclPlatformType *
-TclWinGetPlatform()
-{
- return &tclPlatform;
+ pathPtr = TclGetLibraryPath();
+ if (pathPtr == NULL) {
+ pathPtr = Tcl_NewObj();
+ }
+ Tcl_SetVar2Ex(interp, "tcl_libPath", NULL, pathPtr, TCL_GLOBAL_ONLY);
+ return Tcl_Eval(interp, initScript);
}
/*
@@ -400,8 +750,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);
}
}
}
@@ -435,5 +785,5 @@ TclpAsyncMark(async)
* asynchronous events.
*/
- PostThreadMessage(threadId, WM_USER, 0, 0);
+ PostThreadMessage(mainThreadId, WM_USER, 0, 0);
}
diff --git a/win/tclWinInt.h b/win/tclWinInt.h
index e0e1903..025b728 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.
*
- * RCS: @(#) $Id: tclWinInt.h,v 1.6 1999/03/10 05:52:53 stanton Exp $
+ * RCS: @(#) $Id: tclWinInt.h,v 1.7 1999/04/16 00:48:09 stanton Exp $
*/
#ifndef _TCLWININT
@@ -21,11 +21,6 @@
#include "tclPort.h"
#endif
-#ifdef BUILD_tcl
-# undef TCL_STORAGE_CLASS
-# define TCL_STORAGE_CLASS DLLEXPORT
-#endif
-
/*
* The following specifies how much stack space TclpCheckStackSpace()
* ensures is available. TclpCheckStackSpace() is called by Tcl_EvalObj()
@@ -34,6 +29,11 @@
#define TCL_WIN_STACK_THRESHOLD 0x2000
+#ifdef BUILD_tcl
+# undef TCL_STORAGE_CLASS
+# define TCL_STORAGE_CLASS DLLEXPORT
+#endif
+
/*
* Some versions of Borland C have a define for the OSVERSIONINFO for
* Win32s and for NT, but not for Windows 95.
@@ -44,13 +44,69 @@
#endif
/*
+ * The following structure keeps track of whether we are using the
+ * multi-byte or the wide-character interfaces to the operating system.
+ * System calls should be made through the following function table.
+ */
+
+typedef union {
+ WIN32_FIND_DATAA a;
+ WIN32_FIND_DATAW w;
+} WIN32_FIND_DATAT;
+
+typedef struct TclWinProcs {
+ int useWide;
+
+ BOOL (WINAPI *buildCommDCBProc)(CONST TCHAR *, LPDCB);
+ TCHAR *(WINAPI *charLowerProc)(TCHAR *);
+ BOOL (WINAPI *copyFileProc)(CONST TCHAR *, CONST TCHAR *, BOOL);
+ BOOL (WINAPI *createDirectoryProc)(CONST TCHAR *, LPSECURITY_ATTRIBUTES);
+ HANDLE (WINAPI *createFileProc)(CONST TCHAR *, DWORD, DWORD,
+ LPSECURITY_ATTRIBUTES, DWORD, DWORD, HANDLE);
+ BOOL (WINAPI *createProcessProc)(CONST TCHAR *, TCHAR *,
+ LPSECURITY_ATTRIBUTES, LPSECURITY_ATTRIBUTES, BOOL, DWORD,
+ LPVOID, CONST TCHAR *, LPSTARTUPINFOA, LPPROCESS_INFORMATION);
+ BOOL (WINAPI *deleteFileProc)(CONST TCHAR *);
+ HANDLE (WINAPI *findFirstFileProc)(CONST TCHAR *, WIN32_FIND_DATAT *);
+ BOOL (WINAPI *findNextFileProc)(HANDLE, WIN32_FIND_DATAT *);
+ BOOL (WINAPI *getComputerNameProc)(WCHAR *, LPDWORD);
+ DWORD (WINAPI *getCurrentDirectoryProc)(DWORD, WCHAR *);
+ DWORD (WINAPI *getFileAttributesProc)(CONST TCHAR *);
+ DWORD (WINAPI *getFullPathNameProc)(CONST TCHAR *, DWORD nBufferLength,
+ WCHAR *, TCHAR **);
+ DWORD (WINAPI *getModuleFileNameProc)(HMODULE, WCHAR *, int);
+ DWORD (WINAPI *getShortPathNameProc)(CONST TCHAR *, WCHAR *, DWORD);
+ UINT (WINAPI *getTempFileNameProc)(CONST TCHAR *, CONST TCHAR *, UINT,
+ WCHAR *);
+ DWORD (WINAPI *getTempPathProc)(DWORD, WCHAR *);
+ BOOL (WINAPI *getVolumeInformationProc)(CONST TCHAR *, WCHAR *, DWORD,
+ LPDWORD, LPDWORD, LPDWORD, WCHAR *, DWORD);
+ HINSTANCE (WINAPI *loadLibraryProc)(CONST TCHAR *);
+ TCHAR (WINAPI *lstrcpyProc)(WCHAR *, CONST TCHAR *);
+ BOOL (WINAPI *moveFileProc)(CONST TCHAR *, CONST TCHAR *);
+ BOOL (WINAPI *removeDirectoryProc)(CONST TCHAR *);
+ DWORD (WINAPI *searchPathProc)(CONST TCHAR *, CONST TCHAR *,
+ CONST TCHAR *, DWORD, WCHAR *, TCHAR **);
+ BOOL (WINAPI *setCurrentDirectoryProc)(CONST TCHAR *);
+ BOOL (WINAPI *setFileAttributesProc)(CONST TCHAR *, DWORD);
+} TclWinProcs;
+
+EXTERN TclWinProcs *tclWinProcs;
+EXTERN Tcl_Encoding tclWinTCharEncoding;
+
+/*
* Declarations of functions that are not accessible by way of the
* stubs table.
*/
+EXTERN TclPlatformType *TclWinGetPlatform(void);
+EXTERN int TclWinGetPlatformId(void);
EXTERN void TclWinInit(HINSTANCE hInst);
+EXTERN void TclWinSetInterfaces(int);
# undef TCL_STORAGE_CLASS
# define TCL_STORAGE_CLASS DLLIMPORT
+#include "tclIntPlatDecls.h"
+
#endif /* _TCLWININT */
diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c
index 01bf6a8..124f5e2 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.
*
- * RCS: @(#) $Id: tclWinLoad.c,v 1.2 1998/09/14 18:40:20 stanton Exp $
+ * RCS: @(#) $Id: tclWinLoad.c,v 1.3 1999/04/16 00:48:09 stanton Exp $
*/
-#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 b459b76..7be9b97 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.
*
- * RCS: @(#) $Id: tclWinMtherr.c,v 1.2 1998/09/14 18:40:20 stanton Exp $
+ * RCS: @(#) $Id: tclWinMtherr.c,v 1.3 1999/04/16 00:48:09 stanton Exp $
*/
-#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 4f3095c..896d92c 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.
*
- * RCS: @(#) $Id: tclWinNotify.c,v 1.2 1998/09/14 18:40:20 stanton Exp $
+ * RCS: @(#) $Id: tclWinNotify.c,v 1.3 1999/04/16 00:48:09 stanton Exp $
*/
-#include "tclInt.h"
-#include "tclPort.h"
+#include "tclWinInt.h"
#include <winsock.h>
/*
@@ -23,129 +22,206 @@
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
+ * Tcl_AlertNotifier. */
/*
* 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. */
+ DWORD thread; /* Identifier for thread associated with this
+ * notifier. */
+ HANDLE event; /* Event object used to wake up the notifier
+ * thread. */
+ int pending; /* Alert message pending, this field is
+ * locked by the notifierMutex. */
HWND hwnd; /* Messaging window. */
int timeout; /* Current timeout value. */
int timerActive; /* 1 if interval timer is running. */
-} notifier;
+} ThreadSpecificData;
+
+static Tcl_ThreadDataKey dataKey;
+
+/*
+ * The following static indicates the number of threads that have
+ * initialized notifiers. It controls the lifetime of the TclNotifier
+ * window class.
+ *
+ * You must hold the notifierMutex lock before accessing this variable.
+ */
+
+static int notifierCount = 0;
+TCL_DECLARE_MUTEX(notifierMutex)
/*
* Static routines defined in this file.
*/
-static void InitNotifier(void);
-static void NotifierExitHandler(ClientData clientData);
static LRESULT CALLBACK NotifierProc(HWND hwnd, UINT message,
WPARAM wParam, LPARAM lParam);
-static void UpdateTimer(int timeout);
+
/*
*----------------------------------------------------------------------
*
- * InitNotifier --
+ * 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,
- 0, 0, 0, 0, NULL, NULL, TclWinGetTclInstance(), NULL);
- Tcl_CreateExitHandler(NotifierExitHandler, NULL);
+ notifierCount++;
+ Tcl_MutexUnlock(&notifierMutex);
+
+ tsdPtr->pending = 0;
+ tsdPtr->timerActive = 0;
+
+ InitializeCriticalSection(&tsdPtr->crit);
+
+ tsdPtr->hwnd = NULL;
+ tsdPtr->thread = GetCurrentThreadId();
+ tsdPtr->event = CreateEvent(NULL, TRUE /* manual */,
+ FALSE /* !signaled */, NULL);
+
+ return (ClientData) tsdPtr;
}
/*
*----------------------------------------------------------------------
*
- * NotifierExitHandler --
+ * Tcl_FinalizeNotifier --
*
* This function is called to cleanup the notifier state before
- * Tcl is unloaded.
+ * a thread is terminated.
*
* Results:
* None.
*
* Side effects:
- * Destroys the notifier window.
+ * May dispose of the notifier window and class.
*
*----------------------------------------------------------------------
*/
-static void
-NotifierExitHandler(
- ClientData clientData) /* Old window proc */
+void
+Tcl_FinalizeNotifier(clientData)
+ ClientData clientData; /* Pointer to notifier data. */
{
- initialized = 0;
- if (notifier.hwnd) {
- KillTimer(notifier.hwnd, INTERVAL_TIMER);
- DestroyWindow(notifier.hwnd);
- UnregisterClass("TclNotifier", TclWinGetTclInstance());
- notifier.hwnd = NULL;
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;
+
+ DeleteCriticalSection(&tsdPtr->crit);
+ CloseHandle(tsdPtr->event);
+
+ /*
+ * Clean up the timer and messaging window for this thread.
+ */
+
+ if (tsdPtr->hwnd) {
+ KillTimer(tsdPtr->hwnd, INTERVAL_TIMER);
+ DestroyWindow(tsdPtr->hwnd);
+ }
+
+ /*
+ * If this is the last thread to use the notifier, unregister
+ * the notifier window class.
+ */
+
+ Tcl_MutexLock(&notifierMutex);
+ notifierCount--;
+ if (notifierCount == 0) {
+ UnregisterClassA("TclNotifier", TclWinGetTclInstance());
}
+ Tcl_MutexUnlock(&notifierMutex);
}
/*
*----------------------------------------------------------------------
*
- * UpdateTimer --
+ * Tcl_AlertNotifier --
*
- * This function starts or stops the notifier interval timer.
+ * Wake up the specified notifier from any thread. This routine
+ * is called by the platform independent notifier code whenever
+ * the Tcl_ThreadAlert routine is called. This routine is
+ * guaranteed not to be called on a given notifier after
+ * Tcl_FinalizeNotifier is called for that notifier. This routine
+ * is typically called from a thread other than the notifier's
+ * thread.
*
* Results:
* None.
*
* Side effects:
- * None.
+ * Sends a message to the messaging window for the notifier
+ * if there isn't already one pending.
*
*----------------------------------------------------------------------
*/
void
-UpdateTimer(
- int timeout) /* ms timeout, 0 means cancel timer */
+Tcl_AlertNotifier(clientData)
+ ClientData clientData; /* Pointer to thread data. */
{
- notifier.timeout = timeout;
- if (timeout != 0) {
- notifier.timerActive = 1;
- SetTimer(notifier.hwnd, INTERVAL_TIMER,
- (unsigned long) notifier.timeout, NULL);
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *) clientData;
+
+ /*
+ * Note that we do not need to lock around access to the hwnd
+ * because the race condition has no effect since any race condition
+ * implies that the notifier thread is already awake.
+ */
+
+ if (tsdPtr->hwnd) {
+ /*
+ * We do need to lock around access to the pending flag.
+ */
+
+ EnterCriticalSection(&tsdPtr->crit);
+ if (!tsdPtr->pending) {
+ PostMessage(tsdPtr->hwnd, WM_WAKEUP, 0, 0);
+ }
+ tsdPtr->pending = 1;
+ LeaveCriticalSection(&tsdPtr->crit);
} else {
- notifier.timerActive = 0;
- KillTimer(notifier.hwnd, INTERVAL_TIMER);
+ SetEvent(tsdPtr->event);
}
}
@@ -171,10 +247,18 @@ void
Tcl_SetTimer(
Tcl_Time *timePtr) /* Maximum block time, or NULL. */
{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
UINT timeout;
- if (!initialized) {
- InitNotifier();
+ /*
+ * We only need to set up an interval timer if we're being called
+ * from an external event loop. If we don't have a window handle
+ * then we just return immediately and let Tcl_WaitForEvent handle
+ * timeouts.
+ */
+
+ if (!tsdPtr->hwnd) {
+ return;
}
if (!timePtr) {
@@ -184,12 +268,69 @@ Tcl_SetTimer(
* Make sure we pass a non-zero value into the timeout argument.
* Windows seems to get confused by zero length timers.
*/
+
timeout = timePtr->sec * 1000 + timePtr->usec / 1000;
if (timeout == 0) {
timeout = 1;
}
}
- UpdateTimer(timeout);
+ tsdPtr->timeout = timeout;
+ if (timeout != 0) {
+ tsdPtr->timerActive = 1;
+ SetTimer(tsdPtr->hwnd, INTERVAL_TIMER,
+ (unsigned long) tsdPtr->timeout, NULL);
+ } else {
+ tsdPtr->timerActive = 0;
+ KillTimer(tsdPtr->hwnd, INTERVAL_TIMER);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ServiceModeHook --
+ *
+ * This function is invoked whenever the service mode changes.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * If this is the first time the notifier is set into
+ * TCL_SERVICE_ALL, then the communication window is created.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_ServiceModeHook(mode)
+ int mode; /* Either TCL_SERVICE_ALL, or
+ * TCL_SERVICE_NONE. */
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ /*
+ * If this is the first time that the notifier has been used from a
+ * modal loop, then create a communication window. Note that after
+ * this point, the application needs to service events in a timely
+ * fashion or Windows will hang waiting for the window to respond
+ * to synchronous system messages. At some point, we may want to
+ * consider destroying the window if we leave the modal loop, but
+ * for now we'll leave it around.
+ */
+
+ if (mode == TCL_SERVICE_ALL && !tsdPtr->hwnd) {
+ tsdPtr->hwnd = CreateWindowA("TclNotifier", "TclNotifier", WS_TILED,
+ 0, 0, 0, 0, NULL, NULL, TclWinGetTclInstance(), NULL);
+ /*
+ * Send an initial message to the window to ensure that we wake up the
+ * notifier once we get into the modal loop. This will force the
+ * notifier to recompute the timeout value and schedule a timer
+ * if one is needed.
+ */
+
+ Tcl_AlertNotifier((ClientData)tsdPtr);
+ }
}
/*
@@ -197,8 +338,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 +359,13 @@ NotifierProc(
WPARAM wParam,
LPARAM lParam)
{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- if (message != WM_TIMER) {
+ if (message == WM_WAKEUP) {
+ EnterCriticalSection(&tsdPtr->crit);
+ tsdPtr->pending = 0;
+ LeaveCriticalSection(&tsdPtr->crit);
+ } else if (message != WM_TIMER) {
return DefWindowProc(hwnd, message, wParam, lParam);
}
@@ -253,52 +401,73 @@ int
Tcl_WaitForEvent(
Tcl_Time *timePtr) /* Maximum block time, or NULL. */
{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
MSG msg;
- int timeout;
-
- if (!initialized) {
- InitNotifier();
- }
+ DWORD timeout, result;
+ int status;
/*
- * Only use the interval timer for non-zero timeouts. This avoids
- * generating useless messages when we really just want to poll.
+ * Compute the timeout in milliseconds.
*/
if (timePtr) {
timeout = timePtr->sec * 1000 + timePtr->usec / 1000;
} else {
- timeout = 0;
+ timeout = INFINITE;
}
- UpdateTimer(timeout);
-
- if (!timePtr || (timeout != 0)
- || PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE)) {
- if (!GetMessage(&msg, NULL, 0, 0)) {
- /*
- * The application is exiting, so repost the quit message
- * and start unwinding.
- */
+ /*
+ * Check to see if there are any messages in the queue before waiting
+ * because MsgWaitForMultipleObjects will not wake up if there are events
+ * currently sitting in the queue.
+ */
- PostQuitMessage(msg.wParam);
- return -1;
- }
+ if (!PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE)) {
+ /*
+ * Wait for something to happen (a signal from another thread, a
+ * message, or timeout).
+ */
+
+ result = MsgWaitForMultipleObjects(1, &tsdPtr->event, FALSE, timeout,
+ QS_ALLINPUT);
+ }
+
+ /*
+ * Check to see if there are any messages to process.
+ */
+ if (PeekMessage(&msg, NULL, 0, 0, PM_NOREMOVE)) {
/*
- * Handle timer expiration as a special case so we don't
- * claim to be doing work when we aren't.
+ * Retrieve and dispatch the first message.
*/
- if (msg.message == WM_TIMER && msg.hwnd == notifier.hwnd) {
- return 0;
- }
+ result = GetMessage(&msg, NULL, 0, 0);
+ if (result == 0) {
+ /*
+ * We received a request to exit this thread (WM_QUIT), so
+ * propagate the quit message and start unwinding.
+ */
+
+ PostQuitMessage(msg.wParam);
+ status = -1;
+ } else if (result == -1) {
+ /*
+ * We got an error from the system. I have no idea why this would
+ * happen, so we'll just unwind.
+ */
- TranslateMessage(&msg);
- DispatchMessage(&msg);
- return 1;
+ status = -1;
+ } else {
+ TranslateMessage(&msg);
+ DispatchMessage(&msg);
+ status = 1;
+ }
+ } else {
+ status = 0;
}
- return 0;
+
+ ResetEvent(tsdPtr->event);
+ return status;
}
/*
diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c
index 8194f64..d91a860 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.
*
- * RCS: @(#) $Id: tclWinPipe.c,v 1.4 1999/03/11 00:19:24 stanton Exp $
+ * RCS: @(#) $Id: tclWinPipe.c,v 1.5 1999/04/16 00:48:09 stanton Exp $
*/
#include "tclWinInt.h"
@@ -27,6 +27,14 @@
static int initialized = 0;
/*
+ * The pipeMutex locks around access to the initialized and procList variables,
+ * and it is used to protect background threads from being terminated while
+ * they are using APIs that hold locks.
+ */
+
+TCL_DECLARE_MUTEX(pipeMutex)
+
+/*
* The following defines identify the various types of applications that
* run under windows. There is special case code for the various types.
*/
@@ -98,17 +106,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 +138,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 +207,33 @@ 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 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 +243,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 +251,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 +273,30 @@ static Tcl_ChannelType pipeChannelType = {
static void
PipeInit()
{
- initialized = 1;
- firstPipePtr = NULL;
- procList = NULL;
- Tcl_CreateEventSource(PipeSetupProc, PipeCheckProc, NULL);
- Tcl_CreateExitHandler(PipeExitHandler, NULL);
+ ThreadSpecificData *tsdPtr;
+
+ /*
+ * Check the initialized flag first, then check again in the mutex.
+ * This is a speed enhancement.
+ */
+
+ if (!initialized) {
+ Tcl_MutexLock(&pipeMutex);
+ if (!initialized) {
+ initialized = 1;
+ procList = NULL;
+ Tcl_CreateExitHandler(ProcExitHandler, NULL);
+ }
+ Tcl_MutexUnlock(&pipeMutex);
+ }
+
+ tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
+ if (tsdPtr == NULL) {
+ tsdPtr = TCL_TSD_INIT(&dataKey);
+ tsdPtr->firstPipePtr = NULL;
+ Tcl_CreateEventSource(PipeSetupProc, PipeCheckProc, NULL);
+ Tcl_CreateThreadExitHandler(PipeExitHandler, NULL);
+ }
}
/*
@@ -237,11 +317,36 @@ PipeInit()
*/
static void
-PipeExitHandler(clientData)
- ClientData clientData; /* Old window proc */
+PipeExitHandler(
+ ClientData clientData) /* Old window proc */
{
Tcl_DeleteEventSource(PipeSetupProc, PipeCheckProc, NULL);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ProcExitHandler --
+ *
+ * This function is called to cleanup the process list before
+ * Tcl is unloaded.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Resets the process list.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+ProcExitHandler(
+ ClientData clientData) /* Old window proc */
+{
+ Tcl_MutexLock(&pipeMutex);
initialized = 0;
+ Tcl_MutexUnlock(&pipeMutex);
}
/*
@@ -262,27 +367,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 +426,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;
@@ -333,7 +486,7 @@ PipeCheckProc(data, flags)
/*
*----------------------------------------------------------------------
*
- * MakeFile --
+ * TclWinMakeFile --
*
* This function constructs a new TclFile from a given data and
* type value.
@@ -347,9 +500,9 @@ PipeCheckProc(data, flags)
*----------------------------------------------------------------------
*/
-static TclFile
-MakeFile(handle)
- HANDLE handle; /* Type-specific data. */
+TclFile
+TclWinMakeFile(
+ HANDLE handle) /* Type-specific data. */
{
WinFile *filePtr;
@@ -363,37 +516,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 +536,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;
+ if (Tcl_GetChannelHandle(channel, direction,
+ (ClientData *) &handle) == TCL_OK) {
+ return TclWinMakeFile(handle);
} else {
- return MakeFile(handle);
+ return (TclFile) NULL;
}
-
- error:
- TclWinConvertError(GetLastError());
- CloseHandle(handle);
- DeleteFile(name);
- return NULL;
}
/*
@@ -546,13 +609,14 @@ 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 +660,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 +684,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;
}
@@ -646,7 +707,98 @@ TclpOpenFile(path, mode)
SetFilePointer(handle, 0, NULL, FILE_END);
}
- return MakeFile(handle);
+ return TclWinMakeFile(handle);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpCreateTempFile --
+ *
+ * This function opens a unique file with the property that it
+ * will be deleted when its file handle is closed. The temporary
+ * file is created in the system temporary directory.
+ *
+ * Results:
+ * Returns a valid TclFile, or NULL on failure.
+ *
+ * Side effects:
+ * Creates a new temporary file.
+ *
+ *----------------------------------------------------------------------
+ */
+
+TclFile
+TclpCreateTempFile(contents)
+ CONST char *contents; /* String to write into temp file, or NULL. */
+{
+ WCHAR name[MAX_PATH];
+ 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 TclWinMakeFile(handle);
+ }
+
+ error:
+ TclWinConvertError(GetLastError());
+ CloseHandle(handle);
+ (*tclWinProcs->deleteFileProc)((TCHAR *) name);
+ return NULL;
}
/*
@@ -667,39 +819,42 @@ 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;
if (CreatePipe(&readHandle, &writeHandle, NULL, 0) != 0) {
- *readPipe = MakeFile(readHandle);
- *writePipe = MakeFile(writeHandle);
+ *readPipe = TclWinMakeFile(readHandle);
+ *writePipe = TclWinMakeFile(writeHandle);
return 1;
}
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 +882,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;
@@ -736,17 +891,28 @@ TclpCloseFile(file)
switch (filePtr->type) {
case WIN_FILE:
case WIN32S_TMPFILE:
- if (CloseHandle(filePtr->handle) == FALSE) {
- TclWinConvertError(GetLastError());
- ckfree((char *) filePtr);
- return -1;
+ /*
+ * Don't close the Win32 handle if the handle is a standard channel
+ * during the exit process. Otherwise, one thread may kill the stdio
+ * of another.
+ */
+
+ if (!TclInExit()
+ || ((GetStdHandle(STD_INPUT_HANDLE) != filePtr->handle)
+ && (GetStdHandle(STD_OUTPUT_HANDLE) != filePtr->handle)
+ && (GetStdHandle(STD_ERROR_HANDLE) != filePtr->handle))) {
+ if (CloseHandle(filePtr->handle) == FALSE) {
+ TclWinConvertError(GetLastError());
+ ckfree((char *) filePtr);
+ return -1;
+ }
}
/*
* Simulate deleting the file on close for Win32s.
*/
if (filePtr->type == WIN32S_TMPFILE) {
- DeleteFile(((TmpFile*)filePtr)->name);
+ DeleteFileA(((TmpFile *) filePtr)->name);
}
break;
@@ -759,13 +925,13 @@ TclpCloseFile(file)
if (pipePtr->file.handle != INVALID_HANDLE_VALUE) {
CloseHandle(pipePtr->file.handle);
}
- DeleteFile(pipePtr->fileName);
+ DeleteFileA(pipePtr->fileName);
ckfree((char *) pipePtr->fileName);
}
break;
default:
- panic("Tcl_CloseFile: unexpected file type");
+ panic("TclpCloseFile: unexpected file type");
}
ckfree((char *) filePtr);
@@ -792,16 +958,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(&pipeMutex);
for (infoPtr = procList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
if (infoPtr->hProcess == (HANDLE) pid) {
+ Tcl_MutexUnlock(&pipeMutex);
return infoPtr->dwProcessId;
}
}
+ Tcl_MutexUnlock(&pipeMutex);
return (unsigned long) -1;
}
@@ -823,7 +992,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 +1003,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 +1066,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 +1085,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 +1099,7 @@ TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile,
break;
}
case WIN32S_PIPE: {
- inputFileName = ((WinPipe*)inputFile)->fileName;
+ inputFileName = (char *) ((WinPipe *) inputFile)->fileName;
break;
}
}
@@ -944,7 +1108,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 +1118,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 +1144,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) {
@@ -1005,7 +1169,7 @@ TclpCreateProcess(interp, argc, argv, inputFile, outputFile, errorFile,
}
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);
}
@@ -1017,7 +1181,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);
@@ -1026,11 +1190,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);
@@ -1140,7 +1304,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 {
@@ -1160,7 +1324,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,
@@ -1271,16 +1435,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);
}
@@ -1338,7 +1508,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) {
@@ -1386,18 +1558,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
@@ -1414,29 +1590,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;
}
@@ -1453,7 +1643,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;
}
@@ -1497,6 +1687,7 @@ ApplicationType(interp, originalName, fullPath)
}
break;
}
+ Tcl_DStringFree(&nameBuf);
if (applType == APPL_NONE) {
TclWinConvertError(GetLastError());
@@ -1513,7 +1704,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;
}
@@ -1538,18 +1732,26 @@ 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;
@@ -1557,21 +1759,21 @@ BuildCommandLine(argc, argv, linePtr)
quote = 1;
} else {
for (start = argv[i]; *start != '\0'; start++) {
- if (isspace(*start)) {
+ if (isspace(*start)) { /* INTL: ISO space. */
quote = 1;
break;
}
}
}
if (quote) {
- Tcl_DStringAppend(linePtr, "\"", 1);
+ Tcl_DStringAppend(&ds, "\"", 1);
}
- 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++;
@@ -1581,19 +1783,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') {
@@ -1601,11 +1803,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);
}
/*
@@ -1636,7 +1840,7 @@ MakeTempFile(namePtr)
{
char name[MAX_PATH];
- if (TempFileName(name) == 0) {
+ if (TempFileName((WCHAR *) name) == 0) {
return NULL;
}
@@ -1665,9 +1869,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;
@@ -1701,29 +1905,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
@@ -1734,7 +1951,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;
@@ -1747,10 +1964,41 @@ 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);
+ SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST);
+ } 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);
+ SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST);
+ } else {
+ infoPtr->writeThread = 0;
+ }
infoPtr->validMask |= TCL_WRITABLE;
}
@@ -1758,9 +2006,11 @@ TclpCreateCommandChannel(readFile, writeFile, errorFile, numPids, pidPtr)
* For backward compatibility with previous versions of Tcl, we
* use "file%d" as the base name for pipes even though it would
* be more natural to use "pipe%d".
+ * Use the pointer to keep the channel names unique, in case
+ * channels share handles (stdin/stdout).
*/
- sprintf(channelName, "file%d", channelId);
+ wsprintfA(channelName, "file%lx", infoPtr);
infoPtr->channel = Tcl_CreateChannel(&pipeChannelType, channelName,
(ClientData) infoPtr, infoPtr->validMask);
@@ -1783,26 +2033,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.
@@ -1815,7 +2065,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]));
}
@@ -1842,9 +2092,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;
@@ -1867,7 +2117,7 @@ PipeBlockModeProc(instanceData, mode)
/*
*----------------------------------------------------------------------
*
- * PipeCloseProc --
+ * PipeClose2Proc --
*
* Closes a pipe based IO channel.
*
@@ -1881,41 +2131,127 @@ 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) {
+ /*
+ * Forcibly terminate the background thread. We cannot rely on the
+ * thread to cleanly terminate itself because we have no way of
+ * closing the pipe handle without blocking in the case where the
+ * thread is in the middle of an I/O operation. Note that we need
+ * to guard against terminating the thread while it is in the
+ * middle of Tcl_ThreadAlert because it won't be able to release
+ * the notifier lock.
+ */
- errorCode = 0;
- if (pipePtr->readFile != NULL) {
+ Tcl_MutexLock(&pipeMutex);
+ TerminateThread(pipePtr->readThread, 0);
+ Tcl_MutexUnlock(&pipeMutex);
+
+ /*
+ * Wait for the thread to terminate. This ensures that we are
+ * completely cleaned up before we leave this function.
+ */
+
+ WaitForSingleObject(pipePtr->readThread, INFINITE);
+ CloseHandle(pipePtr->readThread);
+ CloseHandle(pipePtr->readable);
+ CloseHandle(pipePtr->startReader);
+ pipePtr->readThread = NULL;
+ }
if (TclpCloseFile(pipePtr->readFile) != 0) {
errorCode = errno;
}
+ pipePtr->validMask &= ~TCL_READABLE;
+ pipePtr->readFile = NULL;
}
- if (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);
+
+ /*
+ * Forcibly terminate the background thread. We cannot rely on the
+ * thread to cleanly terminate itself because we have no way of
+ * closing the pipe handle without blocking in the case where the
+ * thread is in the middle of an I/O operation. Note that we need
+ * to guard against terminating the thread while it is in the
+ * middle of Tcl_ThreadAlert because it won't be able to release
+ * the notifier lock.
+ */
+
+ Tcl_MutexLock(&pipeMutex);
+ TerminateThread(pipePtr->writeThread, 0);
+ Tcl_MutexUnlock(&pipeMutex);
+
+
+ /*
+ * Wait for the thread to terminate. This ensures that we are
+ * completely cleaned up before we leave this function.
+ */
+
+ WaitForSingleObject(pipePtr->writeThread, INFINITE);
+ 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
@@ -1935,15 +2271,23 @@ PipeCloseProc(instanceData, interp)
filePtr = (WinFile*)pipePtr->errorFile;
errChan = Tcl_MakeFileChannel((ClientData) filePtr->handle,
TCL_READABLE);
+ ckfree((char *) filePtr);
}
} else {
errChan = NULL;
}
+
result = TclCleanupChildren(interp, pipePtr->numPids, pipePtr->pidPtr,
errChan);
+
if (pipePtr->numPids > 0) {
ckfree((char *) pipePtr->pidPtr);
}
+
+ if (pipePtr->writeBuf != NULL) {
+ ckfree(pipePtr->writeBuf);
+ }
+
ckfree((char*) pipePtr);
if (errorCode == 0) {
@@ -1971,17 +2315,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) {
@@ -1989,7 +2333,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);
}
@@ -1998,50 +2342,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.
+ */
-/* } else if ((count == 0) && (infoPtr->flags & PIPE_ASYNC)) { */
-/* errno = *errorCode = EAGAIN; */
-/* return -1; */
- } else if ((count == 0) && !(infoPtr->flags & PIPE_ASYNC)) {
- bufSize = 1;
+ if (result == -1) {
+ *errorCode = errno;
+ return -1;
+ }
+
+ if (infoPtr->readFlags & PIPE_EXTRABYTE) {
+ /*
+ * The reader thread consumed 1 byte as a side effect of
+ * waiting so we need to move it into the buffer.
+ */
+
+ *buf = infoPtr->extraByte;
+ infoPtr->readFlags &= ~PIPE_EXTRABYTE;
+ buf++;
+ bufSize--;
+ bytesRead = 1;
+
+ /*
+ * If further read attempts would block, return what we have.
+ */
+
+ if (result == 0) {
+ return bytesRead;
}
- } 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;
@@ -2067,27 +2424,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;
+
}
/*
@@ -2112,16 +2520,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;
@@ -2134,7 +2542,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;
@@ -2152,36 +2561,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;
+ }
+ }
}
/*
@@ -2210,27 +2612,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 {
@@ -2239,7 +2643,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) {
@@ -2270,10 +2674,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;
@@ -2282,7 +2686,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);
}
@@ -2321,19 +2725,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.
@@ -2348,6 +2750,7 @@ Tcl_WaitPid(pid, statPtr, options)
* Find the process on the process list.
*/
+ Tcl_MutexLock(&pipeMutex);
prevPtrPtr = &procList;
for (infoPtr = procList; infoPtr != NULL;
prevPtrPtr = &infoPtr->nextPtr, infoPtr = infoPtr->nextPtr) {
@@ -2355,12 +2758,13 @@ Tcl_WaitPid(pid, statPtr, options)
break;
}
}
+ Tcl_MutexUnlock(&pipeMutex);
/*
* If the pid is not one of the processes we know about (we started it)
* then do nothing.
*/
-
+
if (infoPtr == NULL) {
*statPtr = 0;
return 0;
@@ -2431,8 +2835,10 @@ TclWinAddProcess(hProcess, id)
ProcInfo *procPtr = (ProcInfo *) ckalloc(sizeof(ProcInfo));
procPtr->hProcess = hProcess;
procPtr->dwProcessId = id;
+ Tcl_MutexLock(&pipeMutex);
procPtr->nextPtr = procList;
procList = procPtr;
+ Tcl_MutexUnlock(&pipeMutex);
}
/*
@@ -2454,18 +2860,18 @@ TclWinAddProcess(hProcess, id)
/* 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?");
@@ -2473,7 +2879,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),
@@ -2489,10 +2895,302 @@ 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, err;
+ int done = 0;
+
+ while (!done) {
+ /*
+ * Wait for the main thread to signal before attempting to wait.
+ */
+
+ WaitForSingleObject(infoPtr->startReader, INFINITE);
+
+ /*
+ * Try waiting for 0 bytes. This will block until some data is
+ * available on NT, but will return immediately on Win 95. So,
+ * if no data is available after the first read, we block until
+ * we can read a single byte off of the pipe.
+ */
+
+ if ((ReadFile(handle, NULL, 0, &count, NULL) == FALSE)
+ || (PeekNamedPipe(handle, NULL, 0, NULL, &count,
+ NULL) == FALSE)) {
+ /*
+ * The error is a result of an EOF condition, so set the
+ * EOF bit before signalling the main thread.
+ */
+
+ err = GetLastError();
+ if (err == ERROR_BROKEN_PIPE) {
+ infoPtr->readFlags |= PIPE_EOF;
+ done = 1;
+ } else if (err == ERROR_INVALID_HANDLE) {
+ break;
+ }
+ } else if (count == 0) {
+ if (ReadFile(handle, &(infoPtr->extraByte), 1, &count, NULL)
+ != FALSE) {
+ /*
+ * One byte was consumed as a side effect of waiting
+ * for the pipe to become readable.
+ */
+
+ infoPtr->readFlags |= PIPE_EXTRABYTE;
+ } else {
+ err = GetLastError();
+ if (err == ERROR_BROKEN_PIPE) {
+ /*
+ * The error is a result of an EOF condition, so set the
+ * EOF bit before signalling the main thread.
+ */
+
+ infoPtr->readFlags |= PIPE_EOF;
+ done = 1;
+ } else if (err == ERROR_INVALID_HANDLE) {
+ break;
+ }
+ }
+ }
+
+
+ /*
+ * Signal the main thread by signalling the readable event and
+ * then waking up the notifier thread.
+ */
+
+ SetEvent(infoPtr->readable);
+
+ /*
+ * Alert the foreground thread. Note that we need to treat this like
+ * a critical section so the foreground thread does not terminate
+ * this thread while we are holding a mutex in the notifier code.
+ */
+
+ Tcl_MutexLock(&pipeMutex);
+ Tcl_ThreadAlert(infoPtr->threadId);
+ Tcl_MutexUnlock(&pipeMutex);
+ }
+ return 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * PipeWriterThread --
+ *
+ * This function runs in a separate thread and writes data
+ * onto a pipe.
+ *
+ * Results:
+ * Always returns 0.
+ *
+ * Side effects:
+ * Signals the main thread when an output operation is completed.
+ * May cause the main thread to wake up by posting a message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static DWORD WINAPI
+PipeWriterThread(LPVOID arg)
+{
+
+ PipeInfo *infoPtr = (PipeInfo *)arg;
+ HANDLE *handle = ((WinFile *) infoPtr->writeFile)->handle;
+ DWORD count, toWrite;
+ char *buf;
+ int done = 0;
+
+ while (!done) {
+ /*
+ * Wait for the main thread to signal before attempting to write.
+ */
+
+ WaitForSingleObject(infoPtr->startWriter, INFINITE);
+
+ buf = infoPtr->writeBuf;
+ toWrite = infoPtr->toWrite;
+
+ /*
+ * Loop until all of the bytes are written or an error occurs.
+ */
+
+ while (toWrite > 0) {
+ if (WriteFile(handle, buf, toWrite, &count, NULL) == FALSE) {
+ infoPtr->writeError = GetLastError();
+ done = 1;
+ break;
+ } else {
+ toWrite -= count;
+ buf += count;
+ }
+ }
+
+ /*
+ * Signal the main thread by signalling the writable event and
+ * then waking up the notifier thread.
+ */
+
+ SetEvent(infoPtr->writable);
+
+ /*
+ * Alert the foreground thread. Note that we need to treat this like
+ * a critical section so the foreground thread does not terminate
+ * this thread while we are holding a mutex in the notifier code.
+ */
+
+ Tcl_MutexLock(&pipeMutex);
+ Tcl_ThreadAlert(infoPtr->threadId);
+ Tcl_MutexUnlock(&pipeMutex);
+ }
+ return 0;
+}
+
diff --git a/win/tclWinPort.h b/win/tclWinPort.h
index 2bb6b72..4843383 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.
*
- * RCS: @(#) $Id: tclWinPort.h,v 1.7 1999/03/10 05:52:53 stanton Exp $
+ * RCS: @(#) $Id: tclWinPort.h,v 1.8 1999/04/16 00:48:09 stanton Exp $
*/
#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>
@@ -58,28 +84,112 @@
#endif
/*
- * The following defines wrap the system memory allocation routines for
- * use by tclAlloc.c.
- */
-
-#define TclpSysAlloc(size, isBin) ((void*)HeapAlloc(GetProcessHeap(), \
- (DWORD)0, (DWORD)size))
-#define TclpSysFree(ptr) (HeapFree(GetProcessHeap(), \
- (DWORD)0, (HGLOBAL)ptr))
-#define TclpSysRealloc(ptr, size) ((void*)HeapReAlloc(GetProcessHeap(), \
- (DWORD)0, (LPVOID)ptr, (DWORD)size))
-
-/*
- * The 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
@@ -129,17 +239,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
@@ -195,6 +297,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.
*/
@@ -219,112 +333,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 +359,19 @@
*/
#define USE_PUTENV 1
-
+
+/*
+ * The following defines wrap the system memory allocation routines for
+ * use by tclAlloc.c.
+ */
+
+#define TclpSysAlloc(size, isBin) ((void*)HeapAlloc(GetProcessHeap(), \
+ (DWORD)0, (DWORD)size))
+#define TclpSysFree(ptr) (HeapFree(GetProcessHeap(), \
+ (DWORD)0, (HGLOBAL)ptr))
+#define TclpSysRealloc(ptr, size) ((void*)HeapReAlloc(GetProcessHeap(), \
+ (DWORD)0, (LPVOID)ptr, (DWORD)size))
+
/*
* The following defines map from standard socket names to our internal
* wrappers that redirect through the winSock function table (see the
@@ -346,20 +384,53 @@
#define setsockopt TclWinSetSockOpt
/*
- * The following implements the Windows method for exiting the process.
+ * The following macros have trivial definitions, allowing generic code to
+ * address platform-specific issues.
*/
-#define TclPlatformExit(status) exit(status)
+#define TclpReleaseFile(file) ckfree((char *) file)
/*
- * The following prototypes and defines replace the Windows versions
- * of POSIX function that various compiler vendors didn't implement
- * well or consistantly.
+ * The following macros and declarations wrap the C runtime library
+ * functions.
*/
-#define lstat TclStat
+#define TclpExit exit
+#define TclpLstat TclpStat
-#define TclpReleaseFile(file) ckfree((char *) file)
+/*
+ * Declarations for Windows-only functions.
+ */
+
+EXTERN Tcl_Channel TclWinOpenSerialChannel _ANSI_ARGS_((HANDLE handle,
+ char *channelName, int permissions));
+
+EXTERN Tcl_Channel TclWinOpenConsoleChannel _ANSI_ARGS_((HANDLE handle,
+ char *channelName, int permissions));
+
+EXTERN Tcl_Channel TclWinOpenFileChannel _ANSI_ARGS_((HANDLE handle,
+ char *channelName, int permissions, int appendMode));
+
+EXTERN TclFile TclWinMakeFile _ANSI_ARGS_((HANDLE handle));
+
+/*
+ * Platform specific mutex definition used by memory allocators.
+ * These mutexes are statically allocated and explicitly initialized.
+ * Most modules do not use this, but instead use Tcl_Mutex types and
+ * Tcl_MutexLock and Tcl_MutexUnlock that are self-initializing.
+ */
+
+#ifdef TCL_THREADS
+typedef CRITICAL_SECTION TclpMutex;
+EXTERN void TclpMutexInit _ANSI_ARGS_((TclpMutex *mPtr));
+EXTERN void TclpMutexLock _ANSI_ARGS_((TclpMutex *mPtr));
+EXTERN void TclpMutexUnlock _ANSI_ARGS_((TclpMutex *mPtr));
+#else
+typedef int TclpMutex;
+#define TclpMutexInit(a)
+#define TclpMutexLock(a)
+#define TclpMutexUnlock(a)
+#endif /* TCL_THREADS */
#include "tclPlatDecls.h"
#include "tclIntPlatDecls.h"
diff --git a/win/tclWinReg.c b/win/tclWinReg.c
index 0f892df..479435c 100644
--- a/win/tclWinReg.c
+++ b/win/tclWinReg.c
@@ -1,4 +1,4 @@
-/*
+/*
* tclWinReg.c --
*
* This file contains the implementation of the "registry" Tcl
@@ -6,14 +6,15 @@
* loadable extension in a separate DLL.
*
* Copyright (c) 1997 by Sun Microsystems, Inc.
+ * Copyright (c) 1998-1999 by Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclWinReg.c,v 1.8 1999/03/10 05:52:53 stanton Exp $
+ * RCS: @(#) $Id: tclWinReg.c,v 1.9 1999/04/16 00:48:09 stanton Exp $
*/
-#include <tcl.h>
+#include <tclPort.h>
#include <stdlib.h>
#define WIN32_LEAN_AND_MEAN
@@ -35,7 +36,7 @@
#define SWAPWORD(x) MAKEWORD(HIBYTE(x), LOBYTE(x))
#define SWAPLONG(x) MAKELONG(SWAPWORD(HIWORD(x)), SWAPWORD(LOWORD(x)))
-
+
/*
* The following flag is used in OpenKeys to indicate that the specified
* key should be created if it doesn't currently exist.
@@ -67,12 +68,95 @@ static HKEY rootKeys[] = {
*/
static char *typeNames[] = {
- "none", "sz", "expand_sz", "binary", "dword",
+ "none", "sz", "expand_sz", "binary", "dword",
"dword_big_endian", "link", "multi_sz", "resource_list", NULL
};
static DWORD lastType = REG_RESOURCE_LIST;
+/*
+ * The following structures allow us to select between the Unicode and ASCII
+ * interfaces at run time based on whether Unicode APIs are available. The
+ * Unicode APIs are preferable because they will handle characters outside
+ * of the current code page.
+ */
+
+typedef struct RegWinProcs {
+ int useWide;
+
+ LONG (WINAPI *regConnectRegistryProc)(TCHAR *, HKEY, PHKEY);
+ LONG (WINAPI *regCreateKeyExProc)(HKEY, CONST TCHAR *, DWORD, TCHAR *,
+ DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *, DWORD *);
+ LONG (WINAPI *regDeleteKeyProc)(HKEY, CONST TCHAR *);
+ LONG (WINAPI *regDeleteValueProc)(HKEY, CONST TCHAR *);
+ LONG (WINAPI *regEnumKeyProc)(HKEY, DWORD, TCHAR *, DWORD);
+ LONG (WINAPI *regEnumKeyExProc)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
+ TCHAR *, DWORD *, FILETIME *);
+ LONG (WINAPI *regEnumValueProc)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
+ DWORD *, BYTE *, DWORD *);
+ LONG (WINAPI *regOpenKeyExProc)(HKEY, CONST TCHAR *, DWORD, REGSAM,
+ HKEY *);
+ LONG (WINAPI *regQueryInfoKeyProc)(HKEY, TCHAR *, DWORD *, DWORD *,
+ DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *,
+ FILETIME *);
+ LONG (WINAPI *regQueryValueExProc)(HKEY, CONST TCHAR *, DWORD *, DWORD *,
+ BYTE *, DWORD *);
+ LONG (WINAPI *regSetValueExProc)(HKEY, CONST TCHAR *, DWORD, DWORD,
+ CONST BYTE*, DWORD);
+} RegWinProcs;
+
+static RegWinProcs *regWinProcs;
+
+static RegWinProcs asciiProcs = {
+ 0,
+
+ (LONG (WINAPI *)(TCHAR *, HKEY, PHKEY)) RegConnectRegistryA,
+ (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *,
+ DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *,
+ DWORD *)) RegCreateKeyExA,
+ (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyA,
+ (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueA,
+ (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyA,
+ (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
+ TCHAR *, DWORD *, FILETIME *)) RegEnumKeyExA,
+ (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
+ DWORD *, BYTE *, DWORD *)) RegEnumValueA,
+ (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, REGSAM,
+ HKEY *)) RegOpenKeyExA,
+ (LONG (WINAPI *)(HKEY, TCHAR *, DWORD *, DWORD *,
+ DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *,
+ FILETIME *)) RegQueryInfoKeyA,
+ (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD *, DWORD *,
+ BYTE *, DWORD *)) RegQueryValueExA,
+ (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, DWORD,
+ CONST BYTE*, DWORD)) RegSetValueExA,
+};
+
+static RegWinProcs unicodeProcs = {
+ 1,
+
+ (LONG (WINAPI *)(TCHAR *, HKEY, PHKEY)) RegConnectRegistryW,
+ (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, TCHAR *,
+ DWORD, REGSAM, SECURITY_ATTRIBUTES *, HKEY *,
+ DWORD *)) RegCreateKeyExW,
+ (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteKeyW,
+ (LONG (WINAPI *)(HKEY, CONST TCHAR *)) RegDeleteValueW,
+ (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD)) RegEnumKeyW,
+ (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
+ TCHAR *, DWORD *, FILETIME *)) RegEnumKeyExW,
+ (LONG (WINAPI *)(HKEY, DWORD, TCHAR *, DWORD *, DWORD *,
+ DWORD *, BYTE *, DWORD *)) RegEnumValueW,
+ (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, REGSAM,
+ HKEY *)) RegOpenKeyExW,
+ (LONG (WINAPI *)(HKEY, TCHAR *, DWORD *, DWORD *,
+ DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *, DWORD *,
+ FILETIME *)) RegQueryInfoKeyW,
+ (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD *, DWORD *,
+ BYTE *, DWORD *)) RegQueryValueExW,
+ (LONG (WINAPI *)(HKEY, CONST TCHAR *, DWORD, DWORD,
+ CONST BYTE*, DWORD)) RegSetValueExW,
+};
+
/*
* Declarations for functions defined in this file.
@@ -99,15 +183,15 @@ static DWORD OpenSubKey(char *hostName, HKEY rootKey,
static int ParseKeyName(Tcl_Interp *interp, char *name,
char **hostNamePtr, HKEY *rootKeyPtr,
char **keyNamePtr);
-static DWORD RecursiveDeleteKey(HKEY hStartKey, LPTSTR pKeyName);
+static DWORD RecursiveDeleteKey(HKEY hStartKey, TCHAR * pKeyName);
static int RegistryObjCmd(ClientData clientData,
- Tcl_Interp *interp, int objc, Tcl_Obj * CONST objv[]);
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj * CONST objv[]);
static int SetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
Tcl_Obj *valueNameObj, Tcl_Obj *dataObj,
Tcl_Obj *typeObj);
EXTERN int Registry_Init(Tcl_Interp *interp);
-
/*
*----------------------------------------------------------------------
@@ -129,9 +213,26 @@ int
Registry_Init(
Tcl_Interp *interp)
{
+ OSVERSIONINFO os;
+
if (!Tcl_InitStubs(interp, "8.0", 0)) {
return TCL_ERROR;
}
+
+ /*
+ * Determine if the unicode interfaces are available and select the
+ * appropriate registry function table.
+ */
+
+ os.dwOSVersionInfoSize = sizeof(os);
+ GetVersionEx(&os);
+
+ if (os.dwPlatformId == VER_PLATFORM_WIN32_NT) {
+ regWinProcs = &unicodeProcs;
+ } else {
+ regWinProcs = &asciiProcs;
+ }
+
Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd, NULL, NULL);
return Tcl_PkgProvide(interp, "registry", "1.0");
}
@@ -264,6 +365,7 @@ DeleteKey(
DWORD result;
int length;
Tcl_Obj *resultPtr;
+ Tcl_DString buf;
/*
* Find the parent of the key being deleted and open it.
@@ -311,7 +413,9 @@ DeleteKey(
* Now we recursively delete the key and everything below it.
*/
+ tail = Tcl_WinUtfToTChar(tail, -1, &buf);
result = RecursiveDeleteKey(subkey, tail);
+ Tcl_DStringFree(&buf);
if (result != ERROR_SUCCESS && result != ERROR_FILE_NOT_FOUND) {
Tcl_AppendToObj(resultPtr, "unable to delete key: ", -1);
@@ -353,7 +457,8 @@ DeleteValue(
int length;
DWORD result;
Tcl_Obj *resultPtr;
-
+ Tcl_DString ds;
+
/*
* Attempt to open the key for deletion.
*/
@@ -365,11 +470,13 @@ DeleteValue(
resultPtr = Tcl_GetObjResult(interp);
valueName = Tcl_GetStringFromObj(valueNameObj, &length);
- result = RegDeleteValue(key, valueName);
+ Tcl_WinUtfToTChar(valueName, length, &ds);
+ result = (*regWinProcs->regDeleteValueProc)(key, Tcl_DStringValue(&ds));
+ Tcl_DStringFree(&ds);
if (result != ERROR_SUCCESS) {
Tcl_AppendStringsToObj(resultPtr, "unable to delete value \"",
- Tcl_GetStringFromObj(valueNameObj, NULL), "\" from key \"",
- Tcl_GetStringFromObj(keyNameObj, NULL), "\": ", NULL);
+ Tcl_GetString(valueNameObj), "\" from key \"",
+ Tcl_GetString(keyNameObj), "\": ", NULL);
AppendSystemError(interp, result);
result = TCL_ERROR;
} else {
@@ -406,9 +513,10 @@ GetKeyNames(
{
HKEY key;
DWORD index;
- char buffer[MAX_PATH+1], *pattern;
+ char buffer[MAX_PATH+1], *pattern, *name;
Tcl_Obj *resultPtr;
int result = TCL_OK;
+ Tcl_DString ds;
/*
* Attempt to open the key for enumeration.
@@ -420,7 +528,7 @@ GetKeyNames(
}
if (patternObj) {
- pattern = Tcl_GetStringFromObj(patternObj, NULL);
+ pattern = Tcl_GetString(patternObj);
} else {
pattern = NULL;
}
@@ -431,13 +539,17 @@ GetKeyNames(
*/
resultPtr = Tcl_GetObjResult(interp);
- for (index = 0; RegEnumKey(key, index, buffer, MAX_PATH+1)
- == ERROR_SUCCESS; index++) {
- if (pattern && !Tcl_StringMatch(buffer, pattern)) {
+ for (index = 0; (*regWinProcs->regEnumKeyProc)(key, index, buffer,
+ MAX_PATH+1) == ERROR_SUCCESS; index++) {
+ Tcl_WinTCharToUtf((TCHAR *) buffer, -1, &ds);
+ name = Tcl_DStringValue(&ds);
+ if (pattern && !Tcl_StringMatch(name, pattern)) {
+ Tcl_DStringFree(&ds);
continue;
}
result = Tcl_ListObjAppendElement(interp, resultPtr,
- Tcl_NewStringObj(buffer, -1));
+ Tcl_NewStringObj(name, Tcl_DStringLength(&ds)));
+ Tcl_DStringFree(&ds);
if (result != TCL_OK) {
break;
}
@@ -474,7 +586,10 @@ GetType(
Tcl_Obj *resultPtr;
DWORD result;
DWORD type;
-
+ Tcl_DString ds;
+ char *valueName;
+ int length;
+
/*
* Attempt to open the key for reading.
*/
@@ -490,14 +605,17 @@ GetType(
resultPtr = Tcl_GetObjResult(interp);
- result = RegQueryValueEx(key, Tcl_GetStringFromObj(valueNameObj, NULL),
- NULL, &type, NULL, NULL);
+ valueName = Tcl_GetStringFromObj(valueNameObj, &length);
+ valueName = Tcl_WinUtfToTChar(valueName, length, &ds);
+ result = (*regWinProcs->regQueryValueExProc)(key, valueName, NULL, &type,
+ NULL, NULL);
+ Tcl_DStringFree(&ds);
RegCloseKey(key);
if (result != ERROR_SUCCESS) {
Tcl_AppendStringsToObj(resultPtr, "unable to get type of value \"",
- Tcl_GetStringFromObj(valueNameObj, NULL), "\" from key \"",
- Tcl_GetStringFromObj(keyNameObj, NULL), "\": ", NULL);
+ Tcl_GetString(valueNameObj), "\" from key \"",
+ Tcl_GetString(keyNameObj), "\": ", NULL);
AppendSystemError(interp, result);
return TCL_ERROR;
}
@@ -543,7 +661,8 @@ GetValue(
char *valueName;
DWORD result, length, type;
Tcl_Obj *resultPtr;
- Tcl_DString data;
+ Tcl_DString data, buf;
+ int nameLen;
/*
* Attempt to open the key for reading.
@@ -558,30 +677,34 @@ GetValue(
* Initialize a Dstring to maximum statically allocated size
* we could get one more byte by avoiding Tcl_DStringSetLength()
* and just setting length to TCL_DSTRING_STATIC_SIZE, but this
- * should be safer if the implementation Dstrings changes.
+ * should be safer if the implementation of Dstrings changes.
*
* This allows short values to be read from the registy in one call.
* Longer values need a second call with an expanded DString.
*/
Tcl_DStringInit(&data);
- Tcl_DStringSetLength(&data, length = TCL_DSTRING_STATIC_SIZE - 1);
+ length = TCL_DSTRING_STATIC_SIZE - 1;
+ Tcl_DStringSetLength(&data, length);
resultPtr = Tcl_GetObjResult(interp);
-
- valueName = Tcl_GetStringFromObj(valueNameObj, NULL);
- result = RegQueryValueEx(key, valueName, NULL, &type,
- (LPBYTE) Tcl_DStringValue(&data), &length);
+
+ valueName = Tcl_GetStringFromObj(valueNameObj, &nameLen);
+ valueName = Tcl_WinUtfToTChar(valueName, nameLen, &buf);
+
+ result = (*regWinProcs->regQueryValueExProc)(key, valueName, NULL, &type,
+ (BYTE *) Tcl_DStringValue(&data), &length);
if (result == ERROR_MORE_DATA) {
Tcl_DStringSetLength(&data, length);
- result = RegQueryValueEx(key, valueName, NULL, &type,
- (LPBYTE) Tcl_DStringValue(&data), &length);
+ result = (*regWinProcs->regQueryValueExProc)(key, valueName, NULL,
+ &type, (BYTE *) Tcl_DStringValue(&data), &length);
}
+ Tcl_DStringFree(&buf);
RegCloseKey(key);
if (result != ERROR_SUCCESS) {
Tcl_AppendStringsToObj(resultPtr, "unable to get value \"",
- Tcl_GetStringFromObj(valueNameObj, NULL), "\" from key \"",
- Tcl_GetStringFromObj(keyNameObj, NULL), "\": ", NULL);
+ Tcl_GetString(valueNameObj), "\" from key \"",
+ Tcl_GetString(keyNameObj), "\": ", NULL);
AppendSystemError(interp, result);
Tcl_DStringFree(&data);
return TCL_ERROR;
@@ -599,23 +722,38 @@ GetValue(
*((DWORD*) Tcl_DStringValue(&data))));
} else if (type == REG_MULTI_SZ) {
char *p = Tcl_DStringValue(&data);
- char *lastChar = Tcl_DStringValue(&data) + Tcl_DStringLength(&data);
+ char *end = Tcl_DStringValue(&data) + length;
/*
* Multistrings are stored as an array of null-terminated strings,
* terminated by two null characters. Also do a bounds check in
* case we get bogus data.
*/
-
- while (p < lastChar && *p != '\0') {
+
+ while (p < end && ((regWinProcs->useWide)
+ ? *((Tcl_UniChar *)p) : *p) != 0) {
+ Tcl_WinTCharToUtf((TCHAR *) p, -1, &buf);
Tcl_ListObjAppendElement(interp, resultPtr,
- Tcl_NewStringObj(p, -1));
- while (*p++ != '\0') {}
+ Tcl_NewStringObj(Tcl_DStringValue(&buf),
+ Tcl_DStringLength(&buf)));
+ if (regWinProcs->useWide) {
+ while (*((Tcl_UniChar *)p)++ != 0) {}
+ } else {
+ while (*p++ != '\0') {}
+ }
+ Tcl_DStringFree(&buf);
}
} else if ((type == REG_SZ) || (type == REG_EXPAND_SZ)) {
- Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&data), -1);
+ Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&data), -1, &buf);
+ Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&buf),
+ Tcl_DStringLength(&buf));
+ Tcl_DStringFree(&buf);
} else {
- Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&data), length);
+ /*
+ * Save binary data as a byte array.
+ */
+
+ Tcl_SetByteArrayObj(resultPtr, Tcl_DStringValue(&data), length);
}
Tcl_DStringFree(&data);
return result;
@@ -648,9 +786,9 @@ GetValueNames(
{
HKEY key;
Tcl_Obj *resultPtr;
- DWORD index, size, result;
- Tcl_DString buffer;
- char *pattern;
+ DWORD index, size, maxSize, result;
+ Tcl_DString buffer, ds;
+ char *pattern, *name;
/*
* Attempt to open the key for enumeration.
@@ -668,26 +806,27 @@ GetValueNames(
* largest value name plus the terminating null.
*/
- result = RegQueryInfoKey(key, NULL, NULL, NULL, NULL, NULL, NULL, &index,
- &size, NULL, NULL, NULL);
+ result = (*regWinProcs->regQueryInfoKeyProc)(key, NULL, NULL, NULL, NULL,
+ NULL, NULL, &index, &maxSize, NULL, NULL, NULL);
if (result != ERROR_SUCCESS) {
Tcl_AppendStringsToObj(resultPtr, "unable to query key \"",
- Tcl_GetStringFromObj(keyNameObj, NULL), "\": ", NULL);
+ Tcl_GetString(keyNameObj), "\": ", NULL);
AppendSystemError(interp, result);
RegCloseKey(key);
result = TCL_ERROR;
goto done;
}
- size++;
+ maxSize++;
Tcl_DStringInit(&buffer);
- Tcl_DStringSetLength(&buffer, size);
+ Tcl_DStringSetLength(&buffer,
+ (regWinProcs->useWide) ? maxSize*2 : maxSize);
index = 0;
result = TCL_OK;
if (patternObj) {
- pattern = Tcl_GetStringFromObj(patternObj, NULL);
+ pattern = Tcl_GetString(patternObj);
} else {
pattern = NULL;
}
@@ -698,17 +837,29 @@ GetValueNames(
* after each iteration because RegEnumValue smashes the old value.
*/
- while (RegEnumValue(key, index, Tcl_DStringValue(&buffer), &size, NULL,
- NULL, NULL, NULL) == ERROR_SUCCESS) {
- if (!pattern || Tcl_StringMatch(Tcl_DStringValue(&buffer), pattern)) {
+ size = maxSize;
+ while ((*regWinProcs->regEnumValueProc)(key, index,
+ Tcl_DStringValue(&buffer), &size, NULL, NULL, NULL, NULL)
+ == ERROR_SUCCESS) {
+
+ if (regWinProcs->useWide) {
+ size *= 2;
+ }
+
+ Tcl_WinTCharToUtf((TCHAR *) Tcl_DStringValue(&buffer), size, &ds);
+ name = Tcl_DStringValue(&ds);
+ if (!pattern || Tcl_StringMatch(name, pattern)) {
result = Tcl_ListObjAppendElement(interp, resultPtr,
- Tcl_NewStringObj(Tcl_DStringValue(&buffer), size));
+ Tcl_NewStringObj(name, Tcl_DStringLength(&ds)));
if (result != TCL_OK) {
+ Tcl_DStringFree(&ds);
break;
}
}
+ Tcl_DStringFree(&ds);
+
index++;
- size = Tcl_DStringLength(&buffer);
+ size = maxSize;
}
Tcl_DStringFree(&buffer);
@@ -797,13 +948,17 @@ OpenSubKey(
HKEY *keyPtr) /* Returned HKEY. */
{
DWORD result;
+ Tcl_DString buf;
/*
* Attempt to open the root key on a remote host if necessary.
*/
if (hostName) {
- result = RegConnectRegistry(hostName, rootKey, &rootKey);
+ hostName = Tcl_WinUtfToTChar(hostName, -1, &buf);
+ result = (*regWinProcs->regConnectRegistryProc)(hostName, rootKey,
+ &rootKey);
+ Tcl_DStringFree(&buf);
if (result != ERROR_SUCCESS) {
return result;
}
@@ -814,13 +969,16 @@ OpenSubKey(
* that this key must be closed by the caller.
*/
+ keyName = Tcl_WinUtfToTChar(keyName, -1, &buf);
if (flags & REG_CREATE) {
DWORD create;
- result = RegCreateKeyEx(rootKey, keyName, 0, "",
+ result = (*regWinProcs->regCreateKeyExProc)(rootKey, keyName, 0, "",
REG_OPTION_NON_VOLATILE, mode, NULL, keyPtr, &create);
} else {
- result = RegOpenKeyEx(rootKey, keyName, 0, mode, keyPtr);
+ result = (*regWinProcs->regOpenKeyExProc)(rootKey, keyName, 0, mode,
+ keyPtr);
}
+ Tcl_DStringFree(&buf);
/*
* Be sure to close the root key since we are done with it now.
@@ -829,7 +987,7 @@ OpenSubKey(
if (hostName) {
RegCloseKey(rootKey);
}
- return result;
+ return result;
}
/*
@@ -838,7 +996,7 @@ OpenSubKey(
* ParseKeyName --
*
* This function parses a key name into the host, root, and subkey
- * parts.
+ * parts.
*
* Results:
* The pointers to the start of the host and subkey names are
@@ -937,9 +1095,10 @@ ParseKeyName(
static DWORD
RecursiveDeleteKey(
HKEY startKey, /* Parent of key to be deleted. */
- char *keyName) /* Name of key to be deleted. */
+ char *keyName) /* Name of key to be deleted in external
+ * encoding, not UTF. */
{
- DWORD result, subKeyLength;
+ DWORD result, size, maxSize;
Tcl_DString subkey;
HKEY hKey;
@@ -947,35 +1106,36 @@ RecursiveDeleteKey(
* Do not allow NULL or empty key name.
*/
- if (!keyName || lstrlen(keyName) == '\0') {
+ if (!keyName || *keyName == '\0') {
return ERROR_BADKEY;
}
- result = RegOpenKeyEx(startKey, keyName, 0,
+ result = (*regWinProcs->regOpenKeyExProc)(startKey, keyName, 0,
KEY_ENUMERATE_SUB_KEYS | DELETE | KEY_QUERY_VALUE, &hKey);
if (result != ERROR_SUCCESS) {
return result;
}
- result = RegQueryInfoKey(hKey, NULL, NULL, NULL, NULL, &subKeyLength,
- NULL, NULL, NULL, NULL, NULL, NULL);
- subKeyLength++;
+ result = (*regWinProcs->regQueryInfoKeyProc)(hKey, NULL, NULL, NULL, NULL,
+ &maxSize, NULL, NULL, NULL, NULL, NULL, NULL);
+ maxSize++;
if (result != ERROR_SUCCESS) {
return result;
}
Tcl_DStringInit(&subkey);
- Tcl_DStringSetLength(&subkey, subKeyLength);
+ Tcl_DStringSetLength(&subkey,
+ (regWinProcs->useWide) ? maxSize * 2 : maxSize);
while (result == ERROR_SUCCESS) {
/*
* Always get index 0 because key deletion changes ordering.
*/
- subKeyLength = Tcl_DStringLength(&subkey);
- result=RegEnumKeyEx(hKey, 0, Tcl_DStringValue(&subkey), &subKeyLength,
- NULL, NULL, NULL, NULL);
+ size = maxSize;
+ result=(*regWinProcs->regEnumKeyExProc)(hKey, 0,
+ Tcl_DStringValue(&subkey), &size, NULL, NULL, NULL, NULL);
if (result == ERROR_NO_MORE_ITEMS) {
- result = RegDeleteKey(startKey, keyName);
+ result = (*regWinProcs->regDeleteKeyProc)(startKey, keyName);
break;
} else if (result == ERROR_SUCCESS) {
result = RecursiveDeleteKey(hKey, Tcl_DStringValue(&subkey));
@@ -1017,6 +1177,7 @@ SetValue(
int length;
char *valueName;
Tcl_Obj *resultPtr;
+ Tcl_DString nameBuf;
if (typeObj == NULL) {
type = REG_SZ;
@@ -1032,26 +1193,28 @@ SetValue(
}
valueName = Tcl_GetStringFromObj(valueNameObj, &length);
+ valueName = Tcl_WinUtfToTChar(valueName, length, &nameBuf);
resultPtr = Tcl_GetObjResult(interp);
if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) {
DWORD value;
if (Tcl_GetIntFromObj(interp, dataObj, (int*) &value) != TCL_OK) {
RegCloseKey(key);
+ Tcl_DStringFree(&nameBuf);
return TCL_ERROR;
}
value = ConvertDWORD(type, value);
- result = RegSetValueEx(key, valueName, 0, type, (BYTE*) &value,
- sizeof(DWORD));
+ result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type,
+ (BYTE*) &value, sizeof(DWORD));
} else if (type == REG_MULTI_SZ) {
- Tcl_DString data;
+ Tcl_DString data, buf;
int objc, i;
Tcl_Obj **objv;
- char *element;
if (Tcl_ListObjGetElements(interp, dataObj, &objc, &objv) != TCL_OK) {
RegCloseKey(key);
+ Tcl_DStringFree(&nameBuf);
return TCL_ERROR;
}
@@ -1063,29 +1226,55 @@ SetValue(
Tcl_DStringInit(&data);
for (i = 0; i < objc; i++) {
- element = Tcl_GetStringFromObj(objv[i], NULL);
- Tcl_DStringAppend(&data, element, -1);
+ Tcl_DStringAppend(&data, Tcl_GetString(objv[i]), -1);
+
+ /*
+ * Add a null character to separate this value from the next.
+ * We accomplish this by growing the string by one byte. Since the
+ * DString always tacks on an extra null byte, the new byte will
+ * already be set to null.
+ */
+
Tcl_DStringSetLength(&data, Tcl_DStringLength(&data)+1);
}
- result = RegSetValueEx(key, valueName, 0, type,
- (LPBYTE) Tcl_DStringValue(&data),
- (DWORD) (Tcl_DStringLength(&data)+1));
+
+ Tcl_WinUtfToTChar(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1,
+ &buf);
+ result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type,
+ (BYTE *) Tcl_DStringValue(&buf),
+ (DWORD) Tcl_DStringLength(&buf));
Tcl_DStringFree(&data);
- } else {
+ Tcl_DStringFree(&buf);
+ } else if (type == REG_SZ || type == REG_EXPAND_SZ) {
+ Tcl_DString buf;
char *data = Tcl_GetStringFromObj(dataObj, &length);
+ data = Tcl_WinUtfToTChar(data, length, &buf);
+
/*
- * Include the null in the length if we are storing a null terminated
- * string. Note that we also need to call strlen to find the first
- * null so we don't pass bad data to the registry.
+ * Include the null in the length, padding if needed for Unicode.
*/
- if (type == REG_SZ || type == REG_EXPAND_SZ) {
- length = strlen(data) + 1;
+ if (regWinProcs->useWide) {
+ Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1);
}
+ length = Tcl_DStringLength(&buf) + 1;
- result = RegSetValueEx(key, valueName, 0, type, (LPBYTE)data, length);
+ result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type,
+ (BYTE*)data, length);
+ Tcl_DStringFree(&buf);
+ } else {
+ char *data;
+
+ /*
+ * Store binary data in the registry.
+ */
+
+ data = Tcl_GetByteArrayFromObj(dataObj, &length);
+ result = (*regWinProcs->regSetValueExProc)(key, valueName, 0, type,
+ (BYTE *)data, length);
}
+ Tcl_DStringFree(&nameBuf);
RegCloseKey(key);
if (result != ERROR_SUCCESS) {
Tcl_AppendToObj(resultPtr, "unable to set value: ", -1);
@@ -1118,36 +1307,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/tclWinSerial.c b/win/tclWinSerial.c
new file mode 100644
index 0000000..733da67
--- /dev/null
+++ b/win/tclWinSerial.c
@@ -0,0 +1,1401 @@
+/*
+ * Tclwinserial.c --
+ *
+ * This file implements the Windows-specific serial port functions,
+ * and the "serial" channel driver.
+ *
+ * Copyright (c) 1999 by Scriptics Corp.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id: tclWinSerial.c,v 1.2 1999/04/16 00:48:09 stanton Exp $
+ */
+
+#include "tclWinInt.h"
+
+#include <dos.h>
+#include <fcntl.h>
+#include <io.h>
+#include <sys/stat.h>
+
+/*
+ * The following variable is used to tell whether this module has been
+ * initialized.
+ */
+
+static int initialized = 0;
+
+/*
+ * The serialMutex locks around access to the initialized variable, and it is
+ * used to protect background threads from being terminated while they are
+ * using APIs that hold locks.
+ */
+
+TCL_DECLARE_MUTEX(serialMutex)
+
+/*
+ * Bit masks used in the flags field of the SerialInfo structure below.
+ */
+
+#define SERIAL_PENDING (1<<0) /* Message is pending in the queue. */
+#define SERIAL_ASYNC (1<<1) /* Channel is non-blocking. */
+
+/*
+ * Bit masks used in the sharedFlags field of the SerialInfo structure below.
+ */
+
+#define SERIAL_EOF (1<<2) /* Serial has reached EOF. */
+#define SERIAL_EXTRABYTE (1<<3) /* Extra byte consumed while waiting for data */
+/*
+ * This structure describes per-instance data for a serial based channel.
+ */
+
+typedef struct SerialInfo {
+ HANDLE handle;
+ struct SerialInfo *nextPtr; /* Pointer to next registered serial. */
+ Tcl_Channel channel; /* Pointer to channel structure. */
+ int validMask; /* OR'ed combination of TCL_READABLE,
+ * TCL_WRITABLE, or TCL_EXCEPTION: indicates
+ * which operations are valid on the file. */
+ int watchMask; /* OR'ed combination of TCL_READABLE,
+ * TCL_WRITABLE, or TCL_EXCEPTION: indicates
+ * which events should be reported. */
+ int flags; /* State flags, see above for a list. */
+ 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 serial. */
+ HANDLE startReader; /* Auto-reset event used by the main thread to
+ * signal when the reader thread should attempt
+ * to read from the serial. */
+ DWORD writeError; /* An error caused by the last background
+ * write. Set to 0 if no error has been
+ * detected. This word is shared with the
+ * writer thread so access must be
+ * synchronized with the writable object.
+ */
+ char *writeBuf; /* Current background output buffer.
+ * Access is synchronized with the writable
+ * object. */
+ int writeBufLen; /* Size of write buffer. Access is
+ * synchronized with the writable
+ * object. */
+ int toWrite; /* Current amount to be written. Access is
+ * synchronized with the writable object. */
+ int readFlags; /* Flags that are shared with the reader
+ * thread. Access is synchronized with the
+ * readable object. */
+ int writeFlags; /* Flags that are shared with the writer
+ * thread. Access is synchronized with the
+ * readable object. */
+ int readyMask; /* Events that need to be checked on. */
+ char extraByte;
+
+} SerialInfo;
+
+typedef struct ThreadSpecificData {
+ /*
+ * The following pointer refers to the head of the list of serials
+ * that are being watched for file events.
+ */
+
+ SerialInfo *firstSerialPtr;
+} ThreadSpecificData;
+
+static Tcl_ThreadDataKey dataKey;
+
+/*
+ * The following structure is what is added to the Tcl event queue when
+ * serial events are generated.
+ */
+
+typedef struct SerialEvent {
+ Tcl_Event header; /* Information that is standard for
+ * all events. */
+ SerialInfo *infoPtr; /* Pointer to serial info structure. Note
+ * that we still have to verify that the
+ * serial exists before dereferencing this
+ * pointer. */
+} SerialEvent;
+
+/*
+ * Declarations for functions used only in this file.
+ */
+
+static int SerialBlockProc(ClientData instanceData, int mode);
+static void SerialCheckProc(ClientData clientData, int flags);
+static int SerialCloseProc(ClientData instanceData,
+ Tcl_Interp *interp);
+static int SerialEventProc(Tcl_Event *evPtr, int flags);
+static void SerialExitHandler(ClientData clientData);
+static int SerialGetHandleProc(ClientData instanceData,
+ int direction, ClientData *handlePtr);
+static ThreadSpecificData *SerialInit(void);
+static int SerialInputProc(ClientData instanceData, char *buf,
+ int toRead, int *errorCode);
+static int SerialOutputProc(ClientData instanceData, char *buf,
+ int toWrite, int *errorCode);
+static DWORD WINAPI SerialReaderThread(LPVOID arg);
+static void SerialSetupProc(ClientData clientData, int flags);
+static void SerialWatchProc(ClientData instanceData, int mask);
+static DWORD WINAPI SerialWriterThread(LPVOID arg);
+static void ProcExitHandler(ClientData clientData);
+static int WaitForRead(SerialInfo *infoPtr, int blocking);
+static int SerialGetOptionProc _ANSI_ARGS_((ClientData instanceData,
+ Tcl_Interp *interp, char *optionName,
+ Tcl_DString *dsPtr));
+static int SerialSetOptionProc _ANSI_ARGS_((ClientData instanceData,
+ Tcl_Interp *interp, char *optionName,
+ char *value));
+
+/*
+ * This structure describes the channel type structure for command serial
+ * based IO.
+ */
+
+static Tcl_ChannelType serialChannelType = {
+ "serial", /* Type name. */
+ SerialBlockProc, /* Set blocking or non-blocking mode.*/
+ SerialCloseProc, /* Close proc. */
+ SerialInputProc, /* Input proc. */
+ SerialOutputProc, /* Output proc. */
+ NULL, /* Seek proc. */
+ SerialSetOptionProc, /* Set option proc. */
+ SerialGetOptionProc, /* Get option proc. */
+ SerialWatchProc, /* Set up notifier to watch the channel. */
+ SerialGetHandleProc, /* Get an OS handle from channel. */
+};
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SerialInit --
+ *
+ * This function initializes the static variables for this file.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Creates a new event source.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static ThreadSpecificData *
+SerialInit()
+{
+ ThreadSpecificData *tsdPtr;
+
+ /*
+ * Check the initialized flag first, then check it again in the mutex.
+ * This is a speed enhancement.
+ */
+
+ if (!initialized) {
+ Tcl_MutexLock(&serialMutex);
+ if (!initialized) {
+ initialized = 1;
+ Tcl_CreateExitHandler(ProcExitHandler, NULL);
+ }
+ Tcl_MutexUnlock(&serialMutex);
+ }
+
+ tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
+ if (tsdPtr == NULL) {
+ tsdPtr = TCL_TSD_INIT(&dataKey);
+ tsdPtr->firstSerialPtr = NULL;
+ Tcl_CreateEventSource(SerialSetupProc, SerialCheckProc, NULL);
+ Tcl_CreateThreadExitHandler(SerialExitHandler, NULL);
+ }
+ return tsdPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SerialExitHandler --
+ *
+ * This function is called to cleanup the serial module before
+ * Tcl is unloaded.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Removes the serial event source.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+SerialExitHandler(
+ ClientData clientData) /* Old window proc */
+{
+ Tcl_DeleteEventSource(SerialSetupProc, SerialCheckProc, NULL);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ProcExitHandler --
+ *
+ * This function is called to cleanup the process list before
+ * Tcl is unloaded.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Resets the process list.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+ProcExitHandler(
+ ClientData clientData) /* Old window proc */
+{
+ Tcl_MutexLock(&serialMutex);
+ initialized = 0;
+ Tcl_MutexUnlock(&serialMutex);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SerialSetupProc --
+ *
+ * This procedure is invoked before Tcl_DoOneEvent blocks waiting
+ * for an event.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Adjusts the block time if needed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+SerialSetupProc(
+ ClientData data, /* Not used. */
+ int flags) /* Event flags as passed to Tcl_DoOneEvent. */
+{
+ SerialInfo *infoPtr;
+ Tcl_Time blockTime = { 0, 0 };
+ int block = 1;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ if (!(flags & TCL_FILE_EVENTS)) {
+ return;
+ }
+
+ /*
+ * Look to see if any events are already pending. If they are, poll.
+ */
+
+ for (infoPtr = tsdPtr->firstSerialPtr; infoPtr != NULL;
+ infoPtr = infoPtr->nextPtr) {
+ if (infoPtr->watchMask & TCL_WRITABLE) {
+ if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) {
+ block = 0;
+ }
+ }
+ if (infoPtr->watchMask & TCL_READABLE) {
+ if (WaitForRead(infoPtr, 0) >= 0) {
+ block = 0;
+ }
+ }
+ }
+ if (!block) {
+ Tcl_SetMaxBlockTime(&blockTime);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SerialCheckProc --
+ *
+ * This procedure is called by Tcl_DoOneEvent to check the serial
+ * event source for events.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * May queue an event.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+SerialCheckProc(
+ ClientData data, /* Not used. */
+ int flags) /* Event flags as passed to Tcl_DoOneEvent. */
+{
+ SerialInfo *infoPtr;
+ SerialEvent *evPtr;
+ int needEvent;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ if (!(flags & TCL_FILE_EVENTS)) {
+ return;
+ }
+
+ /*
+ * Queue events for any ready serials that don't already have events
+ * queued.
+ */
+
+ for (infoPtr = tsdPtr->firstSerialPtr; infoPtr != NULL;
+ infoPtr = infoPtr->nextPtr) {
+ if (infoPtr->flags & SERIAL_PENDING) {
+ continue;
+ }
+
+ /*
+ * Queue an event if the serial is signaled for reading or writing.
+ */
+
+ needEvent = 0;
+ if (infoPtr->watchMask & TCL_WRITABLE) {
+ if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) {
+ needEvent = 1;
+ }
+ }
+
+ if (infoPtr->watchMask & TCL_READABLE) {
+ if (WaitForRead(infoPtr, 0) >= 0) {
+ needEvent = 1;
+ }
+ }
+
+ if (needEvent) {
+ infoPtr->flags |= SERIAL_PENDING;
+ evPtr = (SerialEvent *) ckalloc(sizeof(SerialEvent));
+ evPtr->header.proc = SerialEventProc;
+ evPtr->infoPtr = infoPtr;
+ Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SerialBlockProc --
+ *
+ * Set blocking or non-blocking mode on channel.
+ *
+ * Results:
+ * 0 if successful, errno when failed.
+ *
+ * Side effects:
+ * Sets the device into blocking or non-blocking mode.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SerialBlockProc(
+ ClientData instanceData, /* Instance data for channel. */
+ int mode) /* TCL_MODE_BLOCKING or
+ * TCL_MODE_NONBLOCKING. */
+{
+ SerialInfo *infoPtr = (SerialInfo *) instanceData;
+
+ /*
+ * Serial IO on Windows can not be switched between blocking & nonblocking,
+ * hence we have to emulate the behavior. This is done in the input
+ * function by checking against a bit in the state. We set or unset the
+ * bit here to cause the input function to emulate the correct behavior.
+ */
+
+ if (mode == TCL_MODE_NONBLOCKING) {
+ infoPtr->flags |= SERIAL_ASYNC;
+ } else {
+ infoPtr->flags &= ~(SERIAL_ASYNC);
+ }
+ return 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SerialCloseProc --
+ *
+ * Closes a serial based IO channel.
+ *
+ * Results:
+ * 0 on success, errno otherwise.
+ *
+ * Side effects:
+ * Closes the physical channel.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SerialCloseProc(
+ ClientData instanceData, /* Pointer to SerialInfo structure. */
+ Tcl_Interp *interp) /* For error reporting. */
+{
+ SerialInfo *serialPtr = (SerialInfo *) instanceData;
+ int errorCode, result = 0;
+ SerialInfo *infoPtr, **nextPtrPtr;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ errorCode = 0;
+ if (serialPtr->readThread) {
+ /*
+ * Forcibly terminate the background thread. We cannot rely on the
+ * thread to cleanly terminate itself because we have no way of
+ * closing the handle without blocking in the case where the
+ * thread is in the middle of an I/O operation. Note that we need
+ * to guard against terminating the thread while it is in the
+ * middle of Tcl_ThreadAlert because it won't be able to release
+ * the notifier lock.
+ */
+
+ Tcl_MutexLock(&serialMutex);
+ TerminateThread(serialPtr->readThread, 0);
+ Tcl_MutexUnlock(&serialMutex);
+
+ /*
+ * Wait for the thread to terminate. This ensures that we are
+ * completely cleaned up before we leave this function.
+ */
+
+ WaitForSingleObject(serialPtr->readThread, INFINITE);
+ CloseHandle(serialPtr->readThread);
+ CloseHandle(serialPtr->readable);
+ CloseHandle(serialPtr->startReader);
+ serialPtr->readThread = NULL;
+ }
+ serialPtr->validMask &= ~TCL_READABLE;
+
+ if (serialPtr->writeThread) {
+ WaitForSingleObject(serialPtr->writable, INFINITE);
+
+ /*
+ * Forcibly terminate the background thread. We cannot rely on the
+ * thread to cleanly terminate itself because we have no way of
+ * closing the handle without blocking in the case where the
+ * thread is in the middle of an I/O operation. Note that we need
+ * to guard against terminating the thread while it is in the
+ * middle of Tcl_ThreadAlert because it won't be able to release
+ * the notifier lock.
+ */
+
+ Tcl_MutexLock(&serialMutex);
+ TerminateThread(serialPtr->writeThread, 0);
+ Tcl_MutexUnlock(&serialMutex);
+
+ /*
+ * Wait for the thread to terminate. This ensures that we are
+ * completely cleaned up before we leave this function.
+ */
+
+ WaitForSingleObject(serialPtr->writeThread, INFINITE);
+ CloseHandle(serialPtr->writeThread);
+ CloseHandle(serialPtr->writable);
+ CloseHandle(serialPtr->startWriter);
+ serialPtr->writeThread = NULL;
+ }
+ serialPtr->validMask &= ~TCL_WRITABLE;
+
+ /*
+ * Don't close the Win32 handle if the handle is a standard channel
+ * during the exit process. Otherwise, one thread may kill the stdio
+ * of another.
+ */
+
+ if (!TclInExit()
+ || ((GetStdHandle(STD_INPUT_HANDLE) != serialPtr->handle)
+ && (GetStdHandle(STD_OUTPUT_HANDLE) != serialPtr->handle)
+ && (GetStdHandle(STD_ERROR_HANDLE) != serialPtr->handle))) {
+ if (CloseHandle(serialPtr->handle) == FALSE) {
+ TclWinConvertError(GetLastError());
+ errorCode = errno;
+ }
+ }
+
+ serialPtr->watchMask &= serialPtr->validMask;
+
+ /*
+ * Remove the file from the list of watched files.
+ */
+
+ for (nextPtrPtr = &(tsdPtr->firstSerialPtr), infoPtr = *nextPtrPtr;
+ infoPtr != NULL;
+ nextPtrPtr = &infoPtr->nextPtr, infoPtr = *nextPtrPtr) {
+ if (infoPtr == (SerialInfo *)serialPtr) {
+ *nextPtrPtr = infoPtr->nextPtr;
+ break;
+ }
+ }
+
+ /*
+ * Wrap the error file into a channel and give it to the cleanup
+ * routine.
+ */
+
+ if (serialPtr->writeBuf != NULL) {
+ ckfree(serialPtr->writeBuf);
+ serialPtr->writeBuf = NULL;
+ }
+
+ ckfree((char*) serialPtr);
+
+ if (errorCode == 0) {
+ return result;
+ }
+ return errorCode;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SerialInputProc --
+ *
+ * Reads input from the IO channel into the buffer given. Returns
+ * count of how many bytes were actually read, and an error indication.
+ *
+ * Results:
+ * A count of how many bytes were read is returned and an error
+ * indication is returned in an output argument.
+ *
+ * Side effects:
+ * Reads input from the actual channel.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SerialInputProc(
+ ClientData instanceData, /* Serial state. */
+ char *buf, /* Where to store data read. */
+ int bufSize, /* How much space is available
+ * in the buffer? */
+ int *errorCode) /* Where to store error code. */
+{
+ SerialInfo *infoPtr = (SerialInfo *) instanceData;
+ DWORD bytesRead = 0;
+ int result;
+ DWORD err;
+
+ *errorCode = 0;
+
+ /*
+ * Synchronize with the reader thread.
+ */
+
+ result = WaitForRead(infoPtr, (infoPtr->flags & SERIAL_ASYNC) ? 0 : 1);
+
+ /*
+ * If an error occurred, return immediately.
+ */
+
+ if (result == -1) {
+ *errorCode = errno;
+ return -1;
+ }
+
+ if (infoPtr->readFlags & SERIAL_EXTRABYTE) {
+
+ /*
+ * If a byte was consumed waiting, then put it in the buffer.
+ */
+
+ *buf = infoPtr->extraByte;
+ infoPtr->readFlags &= ~SERIAL_EXTRABYTE;
+ buf++;
+ bufSize--;
+ bytesRead = 1;
+
+ if (result == 0) {
+ return bytesRead;
+ }
+ }
+
+ if (ReadFile(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize, &bytesRead,
+ NULL) == FALSE) {
+ err = GetLastError();
+ if (err != ERROR_IO_PENDING) {
+ goto error;
+ }
+ }
+
+ return bytesRead;
+
+ error:
+ TclWinConvertError(GetLastError());
+ *errorCode = errno;
+ return -1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SerialOutputProc --
+ *
+ * Writes the given output on the IO channel. Returns count of how
+ * many characters were actually written, and an error indication.
+ *
+ * Results:
+ * A count of how many characters were written is returned and an
+ * error indication is returned in an output argument.
+ *
+ * Side effects:
+ * Writes output on the actual channel.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SerialOutputProc(
+ ClientData instanceData, /* Serial state. */
+ char *buf, /* The data buffer. */
+ int toWrite, /* How many bytes to write? */
+ int *errorCode) /* Where to store error code. */
+{
+ SerialInfo *infoPtr = (SerialInfo *) instanceData;
+ DWORD bytesWritten, timeout, err;
+
+ *errorCode = 0;
+ timeout = (infoPtr->flags & SERIAL_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 & SERIAL_ASYNC) {
+ /*
+ * The serial is non-blocking, so copy the data into the output
+ * buffer and restart the writer thread.
+ */
+
+ if (toWrite > infoPtr->writeBufLen) {
+ /*
+ * Reallocate the buffer to be large enough to hold the data.
+ */
+
+ if (infoPtr->writeBuf) {
+ ckfree(infoPtr->writeBuf);
+ }
+ infoPtr->writeBufLen = toWrite;
+ infoPtr->writeBuf = ckalloc(toWrite);
+ }
+ memcpy(infoPtr->writeBuf, buf, toWrite);
+ infoPtr->toWrite = toWrite;
+ ResetEvent(infoPtr->writable);
+ SetEvent(infoPtr->startWriter);
+ bytesWritten = toWrite;
+ } else {
+ /*
+ * In the blocking case, just try to write the buffer directly.
+ * This avoids an unnecessary copy.
+ */
+ if (WriteFile(infoPtr->handle, (LPVOID) buf, (DWORD) toWrite,
+ &bytesWritten, NULL) == FALSE) {
+ err = GetLastError();
+ if (err != ERROR_IO_PENDING) {
+ TclWinConvertError(GetLastError());
+ goto error;
+ }
+ }
+ }
+ return bytesWritten;
+
+ error:
+ *errorCode = errno;
+ return -1;
+
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SerialEventProc --
+ *
+ * This function is invoked by Tcl_ServiceEvent when a file event
+ * reaches the front of the event queue. This procedure invokes
+ * Tcl_NotifyChannel on the serial.
+ *
+ * Results:
+ * Returns 1 if the event was handled, meaning it should be removed
+ * from the queue. Returns 0 if the event was not handled, meaning
+ * it should stay on the queue. The only time the event isn't
+ * handled is if the TCL_FILE_EVENTS flag bit isn't set.
+ *
+ * Side effects:
+ * Whatever the notifier callback does.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SerialEventProc(
+ Tcl_Event *evPtr, /* Event to service. */
+ int flags) /* Flags that indicate what events to
+ * handle, such as TCL_FILE_EVENTS. */
+{
+ SerialEvent *serialEvPtr = (SerialEvent *)evPtr;
+ SerialInfo *infoPtr;
+ int mask;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ if (!(flags & TCL_FILE_EVENTS)) {
+ return 0;
+ }
+
+ /*
+ * Search through the list of watched serials for the one whose handle
+ * matches the event. We do this rather than simply dereferencing
+ * the handle in the event so that serials can be deleted while the
+ * event is in the queue.
+ */
+
+ for (infoPtr = tsdPtr->firstSerialPtr; infoPtr != NULL;
+ infoPtr = infoPtr->nextPtr) {
+ if (serialEvPtr->infoPtr == infoPtr) {
+ infoPtr->flags &= ~(SERIAL_PENDING);
+ break;
+ }
+ }
+ /*
+ * Remove stale events.
+ */
+
+ if (!infoPtr) {
+ return 1;
+ }
+
+ /*
+ * Check to see if the serial is readable. Note
+ * that we can't tell if a serial is writable, so we always report it
+ * as being writable unless we have detected EOF.
+ */
+
+ mask = 0;
+ if (infoPtr->watchMask & TCL_WRITABLE) {
+ if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) {
+ mask = TCL_WRITABLE;
+ }
+ }
+
+ if (infoPtr->watchMask & TCL_READABLE) {
+ if (WaitForRead(infoPtr, 0) >= 0) {
+ if (infoPtr->readFlags & SERIAL_EOF) {
+ mask = TCL_READABLE;
+ } else {
+ mask |= TCL_READABLE;
+ }
+ }
+ }
+
+ /*
+ * Inform the channel of the events.
+ */
+
+ Tcl_NotifyChannel(infoPtr->channel, infoPtr->watchMask & mask);
+ return 1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SerialWatchProc --
+ *
+ * Called by the notifier to set up to watch for events on this
+ * channel.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+SerialWatchProc(
+ ClientData instanceData, /* Serial state. */
+ int mask) /* What events to watch for, OR-ed
+ * combination of TCL_READABLE,
+ * TCL_WRITABLE and TCL_EXCEPTION. */
+{
+ SerialInfo **nextPtrPtr, *ptr;
+ SerialInfo *infoPtr = (SerialInfo *) instanceData;
+ int oldMask = infoPtr->watchMask;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ /*
+ * Since the file is always ready for events, we set the block time
+ * to zero so we will poll.
+ */
+
+ infoPtr->watchMask = mask & infoPtr->validMask;
+ if (infoPtr->watchMask) {
+ Tcl_Time blockTime = { 0, 0 };
+ if (!oldMask) {
+ infoPtr->nextPtr = tsdPtr->firstSerialPtr;
+ tsdPtr->firstSerialPtr = infoPtr;
+ }
+ Tcl_SetMaxBlockTime(&blockTime);
+ } else {
+ if (oldMask) {
+ /*
+ * Remove the serial port from the list of watched serial ports.
+ */
+
+ for (nextPtrPtr = &(tsdPtr->firstSerialPtr), ptr = *nextPtrPtr;
+ ptr != NULL;
+ nextPtrPtr = &ptr->nextPtr, ptr = *nextPtrPtr) {
+ if (infoPtr == ptr) {
+ *nextPtrPtr = ptr->nextPtr;
+ break;
+ }
+ }
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SerialGetHandleProc --
+ *
+ * Called from Tcl_GetChannelHandle to retrieve OS handles from
+ * inside a command serial port based channel.
+ *
+ * Results:
+ * Returns TCL_OK with the fd in handlePtr, or TCL_ERROR if
+ * there is no handle for the specified direction.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SerialGetHandleProc(
+ ClientData instanceData, /* The serial state. */
+ int direction, /* TCL_READABLE or TCL_WRITABLE */
+ ClientData *handlePtr) /* Where to store the handle. */
+{
+ SerialInfo *infoPtr = (SerialInfo *) instanceData;
+
+ *handlePtr = (ClientData) infoPtr->handle;
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * WaitForRead --
+ *
+ * Wait until some data is available, the serial is at
+ * EOF or the reader thread is blocked waiting for data (if the
+ * channel is in non-blocking mode).
+ *
+ * Results:
+ * Returns 1 if serial is readable. Returns 0 if there is no data
+ * on the serial, 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 serial. If no error occurred, the reader thread is
+ * blocked waiting for a signal from the main thread.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+WaitForRead(
+ SerialInfo *infoPtr, /* Serial state. */
+ int blocking) /* Indicates whether call should be
+ * blocking or not. */
+{
+ DWORD timeout, errors;
+ HANDLE *handle = infoPtr->handle;
+ COMSTAT stat;
+
+ 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. This code is not called in the ReaderThread
+ * in blocking mode, so it needs to be checked here.
+ */
+
+ /*
+ * If the serial has hit EOF, it is always readable.
+ */
+
+ if (infoPtr->readFlags & SERIAL_EOF) {
+ return 1;
+ }
+
+ if (ClearCommError(infoPtr->handle, &errors, &stat)) {
+ /*
+ * If there are errors, then signal an I/O error.
+ */
+
+ if (errors != 0) {
+ errno = EIO;
+ return -1;
+ }
+ }
+
+ /*
+ * If data is in the queue return 1
+ */
+
+ if (stat.cbInQue != 0) {
+ return 1;
+ }
+
+ /*
+ * if there is an extra byte that was consumed while
+ * waiting, but no data in the queue, return 0
+ */
+
+ if (infoPtr->readFlags & SERIAL_EXTRABYTE) {
+ return 0;
+ }
+
+ ResetEvent(infoPtr->readable);
+ SetEvent(infoPtr->startReader);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SerialReaderThread --
+ *
+ * This function runs in a separate thread and waits for input
+ * to become available on a serial.
+ *
+ * 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 serial for each wait operation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static DWORD WINAPI
+SerialReaderThread(LPVOID arg)
+{
+ SerialInfo *infoPtr = (SerialInfo *)arg;
+ HANDLE *handle = infoPtr->handle;
+ DWORD mask = EV_RXCHAR;
+ DWORD count;
+
+ for (;;) {
+ /*
+ * Wait for the main thread to signal before attempting to wait.
+ */
+
+ WaitForSingleObject(infoPtr->startReader, INFINITE);
+
+ /*
+ * Try waiting for a Comm event.
+ */
+
+ WaitCommEvent(handle, NULL, NULL);
+
+
+ /*
+ * try to read one byte
+ */
+
+ if (ReadFile(handle, &(infoPtr->extraByte), 1, &count, NULL)
+ != FALSE) {
+
+ /*
+ * one byte was consumed while waiting to read, keep it
+ */
+
+ if (count != 0) {
+ infoPtr->readFlags |= SERIAL_EXTRABYTE;
+ }
+
+ } else {
+ /*
+ * There is an error, signal an EOF.
+ */
+
+ infoPtr->readFlags |= SERIAL_EOF;
+ }
+
+ /*
+ * Signal the main thread by signalling the readable event and
+ * then waking up the notifier thread.
+ */
+
+ SetEvent(infoPtr->readable);
+
+ /*
+ * Alert the foreground thread. Note that we need to treat this like
+ * a critical section so the foreground thread does not terminate
+ * this thread while we are holding a mutex in the notifier code.
+ */
+
+ Tcl_MutexLock(&serialMutex);
+ Tcl_ThreadAlert(infoPtr->threadId);
+ Tcl_MutexUnlock(&serialMutex);
+ }
+ return 0; /* NOT REACHED */
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SerialWriterThread --
+ *
+ * This function runs in a separate thread and writes data
+ * onto a serial.
+ *
+ * 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
+SerialWriterThread(LPVOID arg)
+{
+
+ SerialInfo *infoPtr = (SerialInfo *)arg;
+ HANDLE *handle = infoPtr->handle;
+ DWORD count, toWrite, err;
+ 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, (LPVOID) buf, (DWORD) toWrite,
+ &count, NULL) == FALSE) {
+ err = GetLastError();
+ if (err != ERROR_IO_PENDING) {
+ TclWinConvertError(GetLastError());
+ infoPtr->writeError = err;
+ break;
+ }
+ } else {
+ toWrite -= count;
+ buf += count;
+ }
+ }
+
+ /*
+ * Signal the main thread by signalling the writable event and
+ * then waking up the notifier thread.
+ */
+
+ SetEvent(infoPtr->writable);
+
+ /*
+ * Alert the foreground thread. Note that we need to treat this like
+ * a critical section so the foreground thread does not terminate
+ * this thread while we are holding a mutex in the notifier code.
+ */
+
+ Tcl_MutexLock(&serialMutex);
+ Tcl_ThreadAlert(infoPtr->threadId);
+ Tcl_MutexUnlock(&serialMutex);
+ }
+ return 0; /* NOT REACHED */
+}
+
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclWinOpenSerialChannel --
+ *
+ * Constructs a Serial port channel for the specified standard OS handle.
+ * This is a helper function to break up the construction of
+ * channels into File, Console, or Serial.
+ *
+ * Results:
+ * Returns the new channel, or NULL.
+ *
+ * Side effects:
+ * May open the channel
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Channel
+TclWinOpenSerialChannel(handle, channelName, permissions)
+ HANDLE handle;
+ char *channelName;
+ int permissions;
+{
+ SerialInfo *infoPtr;
+ COMMTIMEOUTS cto;
+ ThreadSpecificData *tsdPtr;
+ DWORD id;
+
+ tsdPtr = SerialInit();
+
+ SetCommMask(handle, EV_RXCHAR);
+ SetupComm(handle, 4096, 4096);
+ PurgeComm(handle, PURGE_TXABORT | PURGE_RXABORT | PURGE_TXCLEAR
+ | PURGE_RXCLEAR);
+ cto.ReadIntervalTimeout = MAXDWORD;
+ cto.ReadTotalTimeoutMultiplier = MAXDWORD;
+ cto.ReadTotalTimeoutConstant = 1;
+ cto.WriteTotalTimeoutMultiplier = 0;
+ cto.WriteTotalTimeoutConstant = 0;
+ SetCommTimeouts(handle, &cto);
+
+ infoPtr = (SerialInfo *) ckalloc((unsigned) sizeof(SerialInfo));
+ memset(infoPtr, 0, sizeof(SerialInfo));
+
+ infoPtr->validMask = permissions;
+ infoPtr->handle = handle;
+
+ /*
+ * Use the pointer to keep the channel names unique, in case
+ * the handles are shared between multiple channels (stdin/stdout).
+ */
+
+ wsprintfA(channelName, "file%lx", (int) infoPtr);
+
+ infoPtr->channel = Tcl_CreateChannel(&serialChannelType, channelName,
+ (ClientData) infoPtr, permissions);
+
+
+ infoPtr->threadId = Tcl_GetCurrentThread();
+
+ if (permissions & TCL_READABLE) {
+ infoPtr->readable = CreateEvent(NULL, TRUE, TRUE, NULL);
+ infoPtr->startReader = CreateEvent(NULL, FALSE, FALSE, NULL);
+ infoPtr->readThread = CreateThread(NULL, 8000, SerialReaderThread,
+ infoPtr, 0, &id);
+ }
+ if (permissions & TCL_WRITABLE) {
+ infoPtr->writable = CreateEvent(NULL, TRUE, TRUE, NULL);
+ infoPtr->startWriter = CreateEvent(NULL, FALSE, FALSE, NULL);
+ infoPtr->writeThread = CreateThread(NULL, 8000, SerialWriterThread,
+ infoPtr, 0, &id);
+ }
+
+ /*
+ * Files have default translation of AUTO and ^Z eof char, which
+ * means that a ^Z will be accepted as EOF when reading.
+ */
+
+ Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
+ Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}");
+
+ return infoPtr->channel;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SerialSetOptionProc --
+ *
+ * Sets an option on a channel.
+ *
+ * Results:
+ * A standard Tcl result. Also sets the interp's result on error if
+ * interp is not NULL.
+ *
+ * Side effects:
+ * May modify an option on a device.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SerialSetOptionProc(instanceData, interp, optionName, value)
+ ClientData instanceData; /* File state. */
+ Tcl_Interp *interp; /* For error reporting - can be NULL. */
+ char *optionName; /* Which option to set? */
+ char *value; /* New value for option. */
+{
+ SerialInfo *infoPtr;
+ DCB dcb;
+ int len;
+ BOOL result;
+ Tcl_DString ds;
+ TCHAR *native;
+
+ infoPtr = (SerialInfo *) instanceData;
+
+ len = strlen(optionName);
+ if ((len > 1) && (strncmp(optionName, "-mode", len) == 0)) {
+ if (GetCommState(infoPtr->handle, &dcb)) {
+ native = Tcl_WinUtfToTChar(value, -1, &ds);
+ result = (*tclWinProcs->buildCommDCBProc)(native, &dcb);
+ Tcl_DStringFree(&ds);
+
+ if ((result == FALSE) ||
+ (SetCommState(infoPtr->handle, &dcb) == FALSE)) {
+ /*
+ * one should separate the 2 errors...
+ */
+
+ if (interp) {
+ Tcl_AppendResult(interp, "bad value for -mode: should be ",
+ "baud,parity,data,stop", NULL);
+ }
+ return TCL_ERROR;
+ } else {
+ return TCL_OK;
+ }
+ } else {
+ if (interp) {
+ Tcl_AppendResult(interp, "can't get comm state", NULL);
+ }
+ return TCL_ERROR;
+ }
+ } else {
+ return Tcl_BadChannelOption(interp, optionName, "mode");
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SerialGetOptionProc --
+ *
+ * Gets a mode associated with an IO channel. If the optionName arg
+ * is non NULL, retrieves the value of that option. If the optionName
+ * arg is NULL, retrieves a list of alternating option names and
+ * values for the given channel.
+ *
+ * Results:
+ * A standard Tcl result. Also sets the supplied DString to the
+ * string value of the option(s) returned.
+ *
+ * Side effects:
+ * The string returned by this function is in static storage and
+ * may be reused at any time subsequent to the call.
+ *
+ *----------------------------------------------------------------------
+ */
+static int
+SerialGetOptionProc(instanceData, interp, optionName, dsPtr)
+ ClientData instanceData; /* File state. */
+ Tcl_Interp *interp; /* For error reporting - can be NULL. */
+ char *optionName; /* Option to get. */
+ Tcl_DString *dsPtr; /* Where to store value(s). */
+{
+ SerialInfo *infoPtr;
+ DCB dcb;
+ int len;
+
+ infoPtr = (SerialInfo *) instanceData;
+
+ if (optionName == NULL) {
+ Tcl_DStringAppendElement(dsPtr, "-mode");
+ len = 0;
+ } else {
+ len = strlen(optionName);
+ }
+ if ((len == 0) ||
+ ((len > 1) && (strncmp(optionName, "-mode", len) == 0))) {
+ if (GetCommState(infoPtr->handle, &dcb) == 0) {
+ /*
+ * shouldn't we flag an error instead ?
+ */
+
+ Tcl_DStringAppendElement(dsPtr, "");
+
+ } else {
+ char parity;
+ char *stop;
+ char buf[2 * TCL_INTEGER_SPACE + 16];
+
+ parity = 'n';
+ if (dcb.Parity < 4) {
+ parity = "noems"[dcb.Parity];
+ }
+
+ stop = (dcb.StopBits == ONESTOPBIT) ? "1" :
+ (dcb.StopBits == ONE5STOPBITS) ? "1.5" : "2";
+
+ wsprintfA(buf, "%d,%c,%d,%s", dcb.BaudRate, parity, dcb.ByteSize,
+ stop);
+ Tcl_DStringAppendElement(dsPtr, buf);
+ }
+ return TCL_OK;
+ } else {
+ return Tcl_BadChannelOption(interp, optionName, "mode");
+ }
+}
diff --git a/win/tclWinSock.c b/win/tclWinSock.c
index 102feb0..bfcc3a6 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.
*
- * RCS: @(#) $Id: tclWinSock.c,v 1.7 1999/04/15 22:38:48 stanton Exp $
+ * RCS: @(#) $Id: tclWinSock.c,v 1.8 1999/04/16 00:48:09 stanton Exp $
*/
-#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. */
+TCL_DECLARE_MUTEX(socketMutex)
/*
* The following structure contains pointers to all of the WinSock API entry
@@ -34,7 +34,6 @@ static char hostname[255]; /* This buffer should be big enough for
static struct {
HINSTANCE hInstance; /* Handle to WinSock library. */
- HWND hwnd; /* Handle to window for socket messages. */
SOCKET (PASCAL FAR *accept)(SOCKET s, struct sockaddr FAR *addr,
int FAR *addrlen);
int (PASCAL FAR *bind)(SOCKET s, const struct sockaddr FAR *addr,
@@ -142,11 +141,16 @@ 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.
+ */
+
+ HWND hwnd; /* Handle to window for socket messages. */
+ SocketInfo *socketList;
+} ThreadSpecificData;
-static SocketInfo *socketList;
+static Tcl_ThreadDataKey dataKey;
/*
* Static functions defined in this file.
@@ -169,6 +173,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));
@@ -221,6 +227,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.
*
@@ -237,186 +245,203 @@ 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;
- }
+ static WNDCLASSA class;
+ ThreadSpecificData *tsdPtr =
+ (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
- /*
- * Initialize the function table.
- */
-
- if (winSock.hInstance == NULL) {
- return;
+ if (! initialized) {
+ 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)
+ || (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.select = (int (PASCAL FAR *)(int nfds, fd_set FAR * readfds,
+ fd_set FAR * writefds, fd_set FAR * exceptfds,
+ const struct timeval FAR * tiemout))
+ GetProcAddress(winSock.hInstance, "select");
+ winSock.send = (int (PASCAL FAR *)(SOCKET s, const char FAR * buf,
+ int len, int flags)) GetProcAddress(winSock.hInstance, "send");
+ winSock.setsockopt = (int (PASCAL FAR *)(SOCKET s, int level,
+ int optname, const char FAR * optval, int optlen))
+ GetProcAddress(winSock.hInstance, "setsockopt");
+ winSock.shutdown = (int (PASCAL FAR *)(SOCKET s, int how))
+ GetProcAddress(winSock.hInstance, "shutdown");
+ winSock.socket = (SOCKET (PASCAL FAR *)(int af, int type,
+ int protocol)) GetProcAddress(winSock.hInstance, "socket");
+ winSock.gethostbyaddr = (struct hostent FAR * (PASCAL FAR *)
+ (const char FAR *addr, int addrlen, int addrtype))
+ GetProcAddress(winSock.hInstance, "gethostbyaddr");
+ winSock.gethostbyname = (struct hostent FAR * (PASCAL FAR *)
+ (const char FAR *name))
+ GetProcAddress(winSock.hInstance, "gethostbyname");
+ winSock.gethostname = (int (PASCAL FAR *)(char FAR * name,
+ int namelen)) GetProcAddress(winSock.hInstance, "gethostname");
+ winSock.getpeername = (int (PASCAL FAR *)(SOCKET sock,
+ struct sockaddr FAR *name, int FAR *namelen))
+ GetProcAddress(winSock.hInstance, "getpeername");
+ winSock.getservbyname = (struct servent FAR * (PASCAL FAR *)
+ (const char FAR * name, const char FAR * proto))
+ GetProcAddress(winSock.hInstance, "getservbyname");
+ winSock.getsockname = (int (PASCAL FAR *)(SOCKET sock,
+ struct sockaddr FAR *name, int FAR *namelen))
+ GetProcAddress(winSock.hInstance, "getsockname");
+ winSock.WSAStartup = (int (PASCAL FAR *)(WORD wVersionRequired,
+ LPWSADATA lpWSAData)) GetProcAddress(winSock.hInstance, "WSAStartup");
+ winSock.WSACleanup = (int (PASCAL FAR *)(void))
+ GetProcAddress(winSock.hInstance, "WSACleanup");
+ winSock.WSAGetLastError = (int (PASCAL FAR *)(void))
+ GetProcAddress(winSock.hInstance, "WSAGetLastError");
+ winSock.WSAAsyncSelect = (int (PASCAL FAR *)(SOCKET s, HWND hWnd,
+ u_int wMsg, long lEvent))
+ GetProcAddress(winSock.hInstance, "WSAAsyncSelect");
+
+ /*
+ * Now check that all fields are properly initialized. If not, return
+ * zero to indicate that we failed to initialize properly.
+ */
+
+ if ((winSock.hInstance == NULL) ||
+ (winSock.accept == NULL) ||
+ (winSock.bind == NULL) ||
+ (winSock.closesocket == NULL) ||
+ (winSock.connect == NULL) ||
+ (winSock.ioctlsocket == NULL) ||
+ (winSock.getsockopt == NULL) ||
+ (winSock.htons == NULL) ||
+ (winSock.inet_addr == NULL) ||
+ (winSock.inet_ntoa == NULL) ||
+ (winSock.listen == NULL) ||
+ (winSock.ntohs == NULL) ||
+ (winSock.recv == NULL) ||
+ (winSock.select == NULL) ||
+ (winSock.send == NULL) ||
+ (winSock.setsockopt == NULL) ||
+ (winSock.socket == NULL) ||
+ (winSock.gethostbyname == NULL) ||
+ (winSock.gethostbyaddr == NULL) ||
+ (winSock.gethostname == NULL) ||
+ (winSock.getpeername == NULL) ||
+ (winSock.getservbyname == NULL) ||
+ (winSock.getsockname == NULL) ||
+ (winSock.WSAStartup == NULL) ||
+ (winSock.WSACleanup == NULL) ||
+ (winSock.WSAGetLastError == NULL) ||
+ (winSock.WSAAsyncSelect == NULL)) {
+ goto unloadLibrary;
+ }
+
+ /*
+ * Create the async notification window with a new class. We
+ * must create a new class to avoid a Windows 95 bug that causes
+ * us to get the wrong message number for socket events if the
+ * message window is a subclass of a static control.
+ */
+
+ 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)) {
+ TclWinConvertError(GetLastError());
+ (*winSock.WSACleanup)();
+ goto unloadLibrary;
+ }
+
+ /*
+ * Initialize the winsock library and check the version number.
+ */
+
+ if ((*winSock.WSAStartup)(WSA_VERSION_REQD, &wsaData) != 0) {
+ goto unloadLibrary;
+ }
+ if (wsaData.wVersion != WSA_VERSION_REQD) {
+ (*winSock.WSACleanup)();
+ goto unloadLibrary;
+ }
}
- winSock.accept = (SOCKET (PASCAL FAR *)(SOCKET s,
- struct sockaddr FAR *addr, int FAR *addrlen))
- GetProcAddress(winSock.hInstance, "accept");
- winSock.bind = (int (PASCAL FAR *)(SOCKET s,
- const struct sockaddr FAR *addr, int namelen))
- GetProcAddress(winSock.hInstance, "bind");
- winSock.closesocket = (int (PASCAL FAR *)(SOCKET s))
- GetProcAddress(winSock.hInstance, "closesocket");
- winSock.connect = (int (PASCAL FAR *)(SOCKET s,
- const struct sockaddr FAR *name, int namelen))
- GetProcAddress(winSock.hInstance, "connect");
- winSock.ioctlsocket = (int (PASCAL FAR *)(SOCKET s, long cmd,
- u_long FAR *argp)) GetProcAddress(winSock.hInstance, "ioctlsocket");
- winSock.getsockopt = (int (PASCAL FAR *)(SOCKET s,
- int level, int optname, char FAR * optval, int FAR *optlen))
- GetProcAddress(winSock.hInstance, "getsockopt");
- winSock.htons = (u_short (PASCAL FAR *)(u_short hostshort))
- GetProcAddress(winSock.hInstance, "htons");
- winSock.inet_addr = (unsigned long (PASCAL FAR *)(const char FAR *cp))
- GetProcAddress(winSock.hInstance, "inet_addr");
- winSock.inet_ntoa = (char FAR * (PASCAL FAR *)(struct in_addr in))
- GetProcAddress(winSock.hInstance, "inet_ntoa");
- winSock.listen = (int (PASCAL FAR *)(SOCKET s, int backlog))
- GetProcAddress(winSock.hInstance, "listen");
- winSock.ntohs = (u_short (PASCAL FAR *)(u_short netshort))
- GetProcAddress(winSock.hInstance, "ntohs");
- winSock.recv = (int (PASCAL FAR *)(SOCKET s, char FAR * buf,
- int len, int flags)) GetProcAddress(winSock.hInstance, "recv");
- winSock.select = (int (PASCAL FAR *)(int nfds, fd_set FAR * readfds,
- fd_set FAR * writefds, fd_set FAR * exceptfds,
- const struct timeval FAR * tiemout))
- GetProcAddress(winSock.hInstance, "select");
- winSock.send = (int (PASCAL FAR *)(SOCKET s, const char FAR * buf,
- int len, int flags)) GetProcAddress(winSock.hInstance, "send");
- winSock.setsockopt = (int (PASCAL FAR *)(SOCKET s, int level,
- int optname, const char FAR * optval, int optlen))
- GetProcAddress(winSock.hInstance, "setsockopt");
- winSock.shutdown = (int (PASCAL FAR *)(SOCKET s, int how))
- GetProcAddress(winSock.hInstance, "shutdown");
- winSock.socket = (SOCKET (PASCAL FAR *)(int af, int type,
- int protocol)) GetProcAddress(winSock.hInstance, "socket");
- winSock.gethostbyaddr = (struct hostent FAR * (PASCAL FAR *)
- (const char FAR *addr, int addrlen, int addrtype))
- GetProcAddress(winSock.hInstance, "gethostbyaddr");
- winSock.gethostbyname = (struct hostent FAR * (PASCAL FAR *)
- (const char FAR *name))
- GetProcAddress(winSock.hInstance, "gethostbyname");
- winSock.gethostname = (int (PASCAL FAR *)(char FAR * name,
- int namelen)) GetProcAddress(winSock.hInstance, "gethostname");
- winSock.getpeername = (int (PASCAL FAR *)(SOCKET sock,
- struct sockaddr FAR *name, int FAR *namelen))
- GetProcAddress(winSock.hInstance, "getpeername");
- winSock.getservbyname = (struct servent FAR * (PASCAL FAR *)
- (const char FAR * name, const char FAR * proto))
- GetProcAddress(winSock.hInstance, "getservbyname");
- winSock.getsockname = (int (PASCAL FAR *)(SOCKET sock,
- struct sockaddr FAR *name, int FAR *namelen))
- GetProcAddress(winSock.hInstance, "getsockname");
- winSock.WSAStartup = (int (PASCAL FAR *)(WORD wVersionRequired,
- LPWSADATA lpWSAData)) GetProcAddress(winSock.hInstance, "WSAStartup");
- winSock.WSACleanup = (int (PASCAL FAR *)(void))
- GetProcAddress(winSock.hInstance, "WSACleanup");
- winSock.WSAGetLastError = (int (PASCAL FAR *)(void))
- GetProcAddress(winSock.hInstance, "WSAGetLastError");
- winSock.WSAAsyncSelect = (int (PASCAL FAR *)(SOCKET s, HWND hWnd,
- u_int wMsg, long lEvent))
- GetProcAddress(winSock.hInstance, "WSAAsyncSelect");
-
/*
- * Now check that all fields are properly initialized. If not, return
- * zero to indicate that we failed to initialize properly.
+ * Check for per-thread initialization.
*/
- if ((winSock.hInstance == NULL) ||
- (winSock.accept == NULL) ||
- (winSock.bind == NULL) ||
- (winSock.closesocket == NULL) ||
- (winSock.connect == NULL) ||
- (winSock.ioctlsocket == NULL) ||
- (winSock.getsockopt == NULL) ||
- (winSock.htons == NULL) ||
- (winSock.inet_addr == NULL) ||
- (winSock.inet_ntoa == NULL) ||
- (winSock.listen == NULL) ||
- (winSock.ntohs == NULL) ||
- (winSock.recv == NULL) ||
- (winSock.select == NULL) ||
- (winSock.send == NULL) ||
- (winSock.setsockopt == NULL) ||
- (winSock.socket == NULL) ||
- (winSock.gethostbyname == NULL) ||
- (winSock.gethostbyaddr == NULL) ||
- (winSock.gethostname == NULL) ||
- (winSock.getpeername == NULL) ||
- (winSock.getservbyname == NULL) ||
- (winSock.getsockname == NULL) ||
- (winSock.WSAStartup == NULL) ||
- (winSock.WSACleanup == NULL) ||
- (winSock.WSAGetLastError == NULL) ||
- (winSock.WSAAsyncSelect == NULL)) {
- goto unloadLibrary;
- }
+ if (tsdPtr == NULL) {
+ tsdPtr = TCL_TSD_INIT(&dataKey);
+ tsdPtr->socketList = 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;
- }
-
- /*
- * 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.
- */
+ tsdPtr->hwnd = CreateWindowA("TclSocket", "TclSocket",
+ WS_TILED, 0, 0, 0, 0, NULL, NULL, class.hInstance, NULL);
- 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->hwnd == NULL) {
+ goto unloadLibrary;
+ }
+
+ Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL);
+ Tcl_CreateThreadExitHandler(SocketThreadExitHandler, NULL);
}
- Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL);
return;
unloadLibrary:
@@ -428,6 +453,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
@@ -447,22 +500,52 @@ 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. */
+{
+ ThreadSpecificData *tsdPtr =
+ (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
+
+ DestroyWindow(tsdPtr->hwnd);
+
+ 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.
@@ -479,14 +562,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) {
@@ -520,6 +603,7 @@ SocketSetupProc(data, flags)
{
SocketInfo *infoPtr;
Tcl_Time blockTime = { 0, 0 };
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!(flags & TCL_FILE_EVENTS)) {
return;
@@ -529,7 +613,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;
@@ -561,6 +646,7 @@ SocketCheckProc(data, flags)
{
SocketInfo *infoPtr;
SocketEvent *evPtr;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!(flags & TCL_FILE_EVENTS)) {
return;
@@ -572,7 +658,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;
@@ -615,6 +702,7 @@ SocketEventProc(evPtr, flags)
SocketEvent *eventPtr = (SocketEvent *) evPtr;
int mask = 0;
int events;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!(flags & TCL_FILE_EVENTS)) {
return 0;
@@ -624,7 +712,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;
}
@@ -678,26 +767,25 @@ SocketEventProc(evPtr, flags)
/*
* We must check to see if data is really available, since someone
* could have consumed the data in the meantime. Turn off async
- * notification so select will work correctly. If the socket is
+ * notification so select will work correctly. If the socket is
* still readable, notify the channel driver, otherwise reset the
* async select handler and keep waiting.
*/
- (void) (*winSock.WSAAsyncSelect)(infoPtr->socket, winSock.hwnd, 0, 0);
+ (void) (*winSock.WSAAsyncSelect)(infoPtr->socket, tsdPtr->hwnd, 0, 0);
FD_ZERO(&readFds);
FD_SET(infoPtr->socket, &readFds);
timeout.tv_usec = 0;
timeout.tv_sec = 0;
-
+
if ((*winSock.select)(0, &readFds, NULL, NULL, &timeout) != 0) {
mask |= TCL_READABLE;
} else {
- (void) (*winSock.WSAAsyncSelect)(infoPtr->socket, winSock.hwnd,
+ (void) (*winSock.WSAAsyncSelect)(infoPtr->socket, tsdPtr->hwnd,
SOCKET_MESSAGE, infoPtr->selectEvents);
infoPtr->readyEvents &= ~(FD_READ);
}
-
}
if (events & (FD_WRITE | FD_CONNECT)) {
mask |= TCL_WRITABLE;
@@ -768,6 +856,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
@@ -776,7 +865,7 @@ TcpCloseProc(instanceData, interp)
* use sockets.
*/
- if (winSock.hInstance != NULL) {
+ if (SocketsEnabled()) {
/*
* Clean up the OS socket handle. The default Windows setting
@@ -794,13 +883,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;
}
@@ -827,6 +917,7 @@ NewSocketInfo(socket)
SOCKET socket;
{
SocketInfo *infoPtr;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
infoPtr = (SocketInfo *) ckalloc((unsigned) sizeof(SocketInfo));
infoPtr->socket = socket;
@@ -836,8 +927,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;
}
@@ -877,6 +970,8 @@ CreateSocket(interp, port, host, server, myaddr, myport, async)
struct sockaddr_in mysockaddr; /* Socket address for client */
SOCKET sock;
SocketInfo *infoPtr; /* The returned value. */
+ ThreadSpecificData *tsdPtr =
+ (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
/*
* Check that WinSock is initialized; do not call it if not, to
@@ -884,11 +979,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;
}
@@ -1020,7 +1115,7 @@ CreateSocket(interp, port, host, server, myaddr, myport, async)
*/
(*winSock.ioctlsocket)(sock, FIONBIO, &flag);
- (void) (*winSock.WSAAsyncSelect)(infoPtr->socket, winSock.hwnd,
+ (void) (*winSock.WSAAsyncSelect)(infoPtr->socket, tsdPtr->hwnd,
SOCKET_MESSAGE, infoPtr->selectEvents);
return infoPtr;
@@ -1070,11 +1165,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));
@@ -1138,6 +1233,8 @@ WaitForSocketEvent(infoPtr, events, errorCodePtr)
MSG msg;
int result = 1;
int oldMode;
+ ThreadSpecificData *tsdPtr =
+ (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
/*
* Be sure to disable event servicing so we are truly modal.
@@ -1149,8 +1246,8 @@ WaitForSocketEvent(infoPtr, events, errorCodePtr)
* Reset WSAAsyncSelect so we have a fresh set of events pending.
*/
- (void) (*winSock.WSAAsyncSelect)(infoPtr->socket, winSock.hwnd, 0, 0);
- (void) (*winSock.WSAAsyncSelect)(infoPtr->socket, winSock.hwnd,
+ (void) (*winSock.WSAAsyncSelect)(infoPtr->socket, tsdPtr->hwnd, 0, 0);
+ (void) (*winSock.WSAAsyncSelect)(infoPtr->socket, tsdPtr->hwnd,
SOCKET_MESSAGE, infoPtr->selectEvents);
while (1) {
@@ -1158,7 +1255,7 @@ WaitForSocketEvent(infoPtr, events, errorCodePtr)
* Process all outstanding messages on the socket window.
*/
- while (PeekMessage(&msg, winSock.hwnd, 0, 0, PM_REMOVE)) {
+ while (PeekMessage(&msg, tsdPtr->hwnd, 0, 0, PM_REMOVE)) {
DispatchMessage(&msg);
}
@@ -1181,6 +1278,7 @@ WaitForSocketEvent(infoPtr, events, errorCodePtr)
WaitMessage();
}
+
(void) Tcl_SetServiceMode(oldMode);
return result;
}
@@ -1213,9 +1311,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;
}
@@ -1228,7 +1326,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));
@@ -1268,9 +1366,11 @@ Tcl_MakeTcpClientChannel(sock)
ClientData sock; /* The socket to wrap up into a channel. */
{
SocketInfo *infoPtr;
- char channelName[20];
+ char channelName[16 + TCL_INTEGER_SPACE];
+ ThreadSpecificData *tsdPtr =
+ (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
- if (TclHasSockets(NULL) != TCL_OK) {
+ if (TclpHasSockets(NULL) != TCL_OK) {
return NULL;
}
@@ -1287,10 +1387,10 @@ Tcl_MakeTcpClientChannel(sock)
*/
infoPtr->selectEvents = FD_READ | FD_CLOSE | FD_WRITE;
- (void) (*winSock.WSAAsyncSelect)(infoPtr->socket, winSock.hwnd,
+ (void) (*winSock.WSAAsyncSelect)(infoPtr->socket, tsdPtr->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");
@@ -1325,9 +1425,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;
}
@@ -1343,7 +1443,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);
@@ -1381,7 +1481,9 @@ TcpAccept(infoPtr)
SocketInfo *newInfoPtr;
struct sockaddr_in addr;
int len;
- char channelName[20];
+ char channelName[16 + TCL_INTEGER_SPACE];
+ ThreadSpecificData *tsdPtr =
+ (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
/*
* Accept the incoming connection request.
@@ -1421,10 +1523,10 @@ TcpAccept(infoPtr)
*/
newInfoPtr->selectEvents = (FD_READ | FD_WRITE | FD_CLOSE);
- (void) (*winSock.WSAAsyncSelect)(newInfoPtr->socket, winSock.hwnd,
+ (void) (*winSock.WSAAsyncSelect)(newInfoPtr->socket, tsdPtr->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",
@@ -1476,6 +1578,8 @@ TcpInputProc(instanceData, buf, toRead, errorCodePtr)
SocketInfo *infoPtr = (SocketInfo *) instanceData;
int bytesRead;
int error;
+ ThreadSpecificData *tsdPtr =
+ (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
*errorCodePtr = 0;
@@ -1486,7 +1590,7 @@ TcpInputProc(instanceData, buf, toRead, errorCodePtr)
* use sockets.
*/
- if (winSock.hInstance == NULL) {
+ if (!SocketsEnabled()) {
*errorCodePtr = EFAULT;
return -1;
}
@@ -1518,37 +1622,37 @@ TcpInputProc(instanceData, buf, toRead, errorCodePtr)
*/
while (1) {
- (void) (*winSock.WSAAsyncSelect)(infoPtr->socket, winSock.hwnd,
+ (void) (*winSock.WSAAsyncSelect)(infoPtr->socket, tsdPtr->hwnd,
0, 0);
bytesRead = (*winSock.recv)(infoPtr->socket, buf, toRead, 0);
infoPtr->readyEvents &= ~(FD_READ);
-
+
/*
* Check for end-of-file condition or successful read.
*/
-
+
if (bytesRead == 0) {
infoPtr->flags |= SOCKET_EOF;
}
if (bytesRead != SOCKET_ERROR) {
break;
}
-
+
/*
* If an error occurs after the FD_CLOSE has arrived,
* then ignore the error and report an EOF.
*/
-
+
if (infoPtr->readyEvents & FD_CLOSE) {
infoPtr->flags |= SOCKET_EOF;
bytesRead = 0;
break;
}
-
+
/*
* Check for error condition or underflow in non-blocking case.
*/
-
+
error = (*winSock.WSAGetLastError)();
if ((infoPtr->flags & SOCKET_ASYNC) || (error != WSAEWOULDBLOCK)) {
TclWinConvertWSAError(error);
@@ -1565,11 +1669,11 @@ TcpInputProc(instanceData, buf, toRead, errorCodePtr)
if (!WaitForSocketEvent(infoPtr, FD_READ|FD_CLOSE, errorCodePtr)) {
bytesRead = -1;
break;
- }
+ }
}
- (void) (*winSock.WSAAsyncSelect)(infoPtr->socket, winSock.hwnd,
- SOCKET_MESSAGE, infoPtr->selectEvents);
+ (void) (*winSock.WSAAsyncSelect)(infoPtr->socket, tsdPtr->hwnd,
+ SOCKET_MESSAGE, infoPtr->selectEvents);
return bytesRead;
}
@@ -1600,6 +1704,8 @@ TcpOutputProc(instanceData, buf, toWrite, errorCodePtr)
SocketInfo *infoPtr = (SocketInfo *) instanceData;
int bytesWritten;
int error;
+ ThreadSpecificData *tsdPtr =
+ (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
*errorCodePtr = 0;
@@ -1610,11 +1716,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.
*/
@@ -1625,7 +1731,7 @@ TcpOutputProc(instanceData, buf, toWrite, errorCodePtr)
}
while (1) {
- (void) (*winSock.WSAAsyncSelect)(infoPtr->socket, winSock.hwnd,
+ (void) (*winSock.WSAAsyncSelect)(infoPtr->socket, tsdPtr->hwnd,
0, 0);
bytesWritten = (*winSock.send)(infoPtr->socket, buf, toWrite, 0);
if (bytesWritten != SOCKET_ERROR) {
@@ -1675,7 +1781,7 @@ TcpOutputProc(instanceData, buf, toWrite, errorCodePtr)
}
}
- (void) (*winSock.WSAAsyncSelect)(infoPtr->socket, winSock.hwnd,
+ (void) (*winSock.WSAAsyncSelect)(infoPtr->socket, tsdPtr->hwnd,
SOCKET_MESSAGE, infoPtr->selectEvents);
return bytesWritten;
}
@@ -1719,7 +1825,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
@@ -1728,7 +1834,7 @@ TcpGetOptionProc(instanceData, interp, optionName, dsPtr)
* use sockets.
*/
- if (winSock.hInstance == NULL) {
+ if (!SocketsEnabled()) {
if (interp) {
Tcl_AppendResult(interp, "winsock is not initialized", NULL);
}
@@ -1742,21 +1848,21 @@ TcpGetOptionProc(instanceData, interp, optionName, dsPtr)
}
if ((len > 1) && (optionName[1] == 'e') &&
- (strncmp(optionName, "-error", len) == 0)) {
- int optlen;
- int err, ret;
+ (strncmp(optionName, "-error", len) == 0)) {
+ int optlen;
+ int err, ret;
- optlen = sizeof(int);
- ret = TclWinGetSockOpt(sock, SOL_SOCKET, SO_ERROR,
- (char *)&err, &optlen);
- if (ret == SOCKET_ERROR) {
- err = (*winSock.WSAGetLastError)();
- }
- if (err) {
- TclWinConvertWSAError(err);
- Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(Tcl_GetErrno()), -1);
- }
- return TCL_OK;
+ optlen = sizeof(int);
+ ret = TclWinGetSockOpt(sock, SOL_SOCKET, SO_ERROR,
+ (char *)&err, &optlen);
+ if (ret == SOCKET_ERROR) {
+ err = (*winSock.WSAGetLastError)();
+ }
+ if (err) {
+ TclWinConvertWSAError(err);
+ Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(Tcl_GetErrno()), -1);
+ }
+ return TCL_OK;
}
if ((len == 0) ||
@@ -1779,7 +1885,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);
@@ -1825,7 +1931,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);
@@ -1886,7 +1992,7 @@ TcpWatchProc(instanceData, mask)
infoPtr->watchEvents |= (FD_READ|FD_CLOSE|FD_ACCEPT);
}
if (mask & TCL_WRITABLE) {
- infoPtr->watchEvents |= (FD_WRITE|FD_CONNECT);
+ infoPtr->watchEvents |= (FD_WRITE|FD_CONNECT);
}
/*
@@ -1905,7 +2011,7 @@ TcpWatchProc(instanceData, mask)
*
* TcpGetProc --
*
- * Called from Tcl_GetChannelFile to retrieve an OS handle from inside
+ * Called from Tcl_GetChannelHandle to retrieve an OS handle from inside
* a TCP socket based channel.
*
* Results:
@@ -1958,6 +2064,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);
@@ -1972,7 +2079,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.
@@ -2000,7 +2108,7 @@ SocketProc(hwnd, message, wParam, lParam)
}
}
- if (infoPtr->flags & SOCKET_ASYNC_CONNECT) {
+ if(infoPtr->flags & SOCKET_ASYNC_CONNECT) {
infoPtr->flags &= ~(SOCKET_ASYNC_CONNECT);
if (error != ERROR_SUCCESS) {
TclWinConvertWSAError(error);
@@ -2044,29 +2152,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;
}
@@ -2090,7 +2211,7 @@ Tcl_GetHostName()
*/
int
-TclWinGetSockOpt(SOCKET s, int level, int optname, char FAR * optval,
+TclWinGetSockOpt(SOCKET s, int level, int optname, char * optval,
int FAR *optlen)
{
/*
@@ -2100,7 +2221,7 @@ TclWinGetSockOpt(SOCKET s, int level, int optname, char FAR * optval,
* use sockets.
*/
- if (winSock.hInstance == NULL) {
+ if (!SocketsEnabled()) {
return SOCKET_ERROR;
}
@@ -2108,7 +2229,7 @@ TclWinGetSockOpt(SOCKET s, int level, int optname, char FAR * optval,
}
int
-TclWinSetSockOpt(SOCKET s, int level, int optname, const char FAR * optval,
+TclWinSetSockOpt(SOCKET s, int level, int optname, const char * optval,
int optlen)
{
/*
@@ -2117,8 +2238,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;
}
@@ -2135,7 +2255,7 @@ TclWinNToHS(u_short netshort)
* use sockets.
*/
- if (winSock.hInstance == NULL) {
+ if (!SocketsEnabled()) {
return (u_short) -1;
}
@@ -2151,8 +2271,7 @@ TclWinGetServByName(const char * name, const char * proto)
* handler for WinSock ran before other exit handlers that want to
* use sockets.
*/
-
- if (winSock.hInstance == NULL) {
+ if (!SocketsEnabled()) {
return (struct servent *) NULL;
}
diff --git a/win/tclWinTest.c b/win/tclWinTest.c
index 077969a..826355f 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.
*
- * RCS: @(#) $Id: tclWinTest.c,v 1.2 1998/09/14 18:40:20 stanton Exp $
+ * RCS: @(#) $Id: tclWinTest.c,v 1.3 1999/04/16 00:48:10 stanton Exp $
*/
-#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..ade458e
--- /dev/null
+++ b/win/tclWinThrd.c
@@ -0,0 +1,900 @@
+/*
+ * tclWinThread.c --
+ *
+ * This file implements the Windows-specific thread operations.
+ *
+ * Copyright (c) 1998 by Sun Microsystems, Inc.
+ * Copyright (c) 1999 by Scriptics Corporation
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * 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;
+
+/*
+ * Condition variables are implemented with a combination of a
+ * per-thread Windows Event and a per-condition waiting queue.
+ * The idea is that each thread has its own Event that it waits
+ * on when it is doing a ConditionWait; it uses the same event for
+ * all condition variables because it only waits on one at a time.
+ * Each condition variable has a queue of waiting threads, and a
+ * mutex used to serialize access to this queue.
+ *
+ * Special thanks to David Nichols and
+ * Jim Davidson for advice on the Condition Variable implementation.
+ */
+
+/*
+ * The per-thread event and queue pointers.
+ */
+
+typedef struct ThreadSpecificData {
+ HANDLE condEvent; /* Per-thread condition event */
+ struct ThreadSpecificData *nextPtr; /* Queue pointers */
+ struct ThreadSpecificData *prevPtr;
+ int flags; /* See flags below */
+} ThreadSpecificData;
+static Tcl_ThreadDataKey dataKey;
+
+/*
+ * State bits for the thread.
+ * WIN_THREAD_UNINIT Uninitialized. Must be zero because
+ * of the way ThreadSpecificData is created.
+ * WIN_THREAD_RUNNING Running, not waiting.
+ * WIN_THREAD_BLOCKED Waiting, or trying to wait.
+ * WIN_THREAD_DEAD Dying - no per-thread event anymore.
+ */
+
+#define WIN_THREAD_UNINIT 0x0
+#define WIN_THREAD_RUNNING 0x1
+#define WIN_THREAD_BLOCKED 0x2
+#define WIN_THREAD_DEAD 0x4
+
+/*
+ * The per condition queue pointers and the
+ * Mutex used to serialize access to the queue.
+ */
+
+typedef struct WinCondition {
+ CRITICAL_SECTION condLock; /* Lock to serialize queuing on the condition */
+ struct ThreadSpecificData *firstPtr; /* Queue pointers */
+ struct ThreadSpecificData *lastPtr;
+} WinCondition;
+
+static void FinalizeConditionEvent(ClientData data);
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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_Finalize.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * May block the current thread. The mutex is aquired when
+ * this returns.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_MutexLock(mutexPtr)
+ Tcl_Mutex *mutexPtr; /* The lock */
+{
+ CRITICAL_SECTION *csPtr;
+ if (*mutexPtr == NULL) {
+ MASTER_LOCK;
+
+ /*
+ * Double inside master lock check to avoid a race.
+ */
+
+ if (*mutexPtr == NULL) {
+ csPtr = (CRITICAL_SECTION *)ckalloc(sizeof(CRITICAL_SECTION));
+ InitializeCriticalSection(csPtr);
+ *mutexPtr = (Tcl_Mutex)csPtr;
+ TclRememberMutex(mutexPtr);
+ }
+ MASTER_UNLOCK;
+ }
+ csPtr = *((CRITICAL_SECTION **)mutexPtr);
+ EnterCriticalSection(csPtr);
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_MutexUnlock --
+ *
+ * This procedure is invoked to unlock a mutex.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The mutex is released when this returns.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_MutexUnlock(mutexPtr)
+ Tcl_Mutex *mutexPtr; /* The lock */
+{
+ CRITICAL_SECTION *csPtr = *((CRITICAL_SECTION **)mutexPtr);
+ LeaveCriticalSection(csPtr);
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpFinalizeMutex --
+ *
+ * This procedure is invoked to clean up one mutex. This is only
+ * safe to call at the end of time.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The mutex list is deallocated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpFinalizeMutex(mutexPtr)
+ Tcl_Mutex *mutexPtr;
+{
+ CRITICAL_SECTION *csPtr = *(CRITICAL_SECTION **)mutexPtr;
+ if (csPtr != NULL) {
+ ckfree((char *)csPtr);
+ *mutexPtr = NULL;
+ }
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpThreadDataKeyInit --
+ *
+ * This procedure initializes a thread specific data block key.
+ * Each thread has table of pointers to thread specific data.
+ * all threads agree on which table entry is used by each module.
+ * this is remembered in a "data key", that is just an index into
+ * this table. To allow self initialization, the interface
+ * passes a pointer to this key and the first thread to use
+ * the key fills in the pointer to the key. The key should be
+ * a process-wide static.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Will allocate memory the first time this process calls for
+ * this key. In this case it modifies its argument
+ * to hold the pointer to information about the key.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpThreadDataKeyInit(keyPtr)
+ Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk,
+ * really (DWORD **) */
+{
+ DWORD *indexPtr;
+
+ MASTER_LOCK;
+ if (*keyPtr == NULL) {
+ indexPtr = (DWORD *)ckalloc(sizeof(DWORD));
+ *indexPtr = TlsAlloc();
+ *keyPtr = (Tcl_ThreadDataKey)indexPtr;
+ TclRememberDataKey(keyPtr);
+ }
+ MASTER_UNLOCK;
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpThreadDataKeyGet --
+ *
+ * This procedure returns a pointer to a block of thread local storage.
+ *
+ * Results:
+ * A thread-specific pointer to the data structure, or NULL
+ * if the memory has not been assigned to this key for this thread.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+VOID *
+TclpThreadDataKeyGet(keyPtr)
+ Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk,
+ * really (DWORD **) */
+{
+ DWORD *indexPtr = *(DWORD **)keyPtr;
+ if (indexPtr == NULL) {
+ return NULL;
+ } else {
+ return (VOID *) TlsGetValue(*indexPtr);
+ }
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpThreadDataKeySet --
+ *
+ * This procedure sets the pointer to a block of thread local storage.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Sets up the thread so future calls to TclpThreadDataKeyGet with
+ * this key will return the data pointer.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpThreadDataKeySet(keyPtr, data)
+ Tcl_ThreadDataKey *keyPtr; /* Identifier for the data chunk,
+ * really (pthread_key_t **) */
+ VOID *data; /* Thread local storage */
+{
+ DWORD *indexPtr = *(DWORD **)keyPtr;
+ TlsSetValue(*indexPtr, (void *)data);
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpFinalizeThreadData --
+ *
+ * This procedure cleans up the thread-local storage. This is
+ * called once for each thread.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Frees up the memory.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpFinalizeThreadData(keyPtr)
+ Tcl_ThreadDataKey *keyPtr;
+{
+ VOID *result;
+ DWORD *indexPtr;
+
+ if (*keyPtr != NULL) {
+ indexPtr = *(DWORD **)keyPtr;
+ result = (VOID *)TlsGetValue(*indexPtr);
+ if (result != NULL) {
+ ckfree((char *)result);
+ TlsSetValue(*indexPtr, (void *)NULL);
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpFinalizeThreadDataKey --
+ *
+ * This procedure is invoked to clean up one key. This is a
+ * process-wide storage identifier. The thread finalization code
+ * cleans up the thread local storage itself.
+ *
+ * This assumes the master lock is held.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The key is deallocated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpFinalizeThreadDataKey(keyPtr)
+ Tcl_ThreadDataKey *keyPtr;
+{
+ DWORD *indexPtr;
+ if (*keyPtr != NULL) {
+ indexPtr = *(DWORD **)keyPtr;
+ TlsFree(*indexPtr);
+ ckfree((char *)indexPtr);
+ *keyPtr = NULL;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ConditionWait --
+ *
+ * This procedure is invoked to wait on a condition variable.
+ * The mutex is automically released as part of the wait, and
+ * automatically grabbed when the condition is signaled.
+ *
+ * The mutex must be held when this procedure is called.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * May block the current thread. The mutex is aquired when
+ * this returns. Will allocate memory for a HANDLE
+ * and initialize this the first time this Tcl_Condition is used.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_ConditionWait(condPtr, mutexPtr, timePtr)
+ Tcl_Condition *condPtr; /* Really (WinCondition **) */
+ Tcl_Mutex *mutexPtr; /* Really (CRITICAL_SECTION **) */
+ Tcl_Time *timePtr; /* Timeout on waiting period */
+{
+ WinCondition *winCondPtr; /* Per-condition queue head */
+ CRITICAL_SECTION *csPtr; /* Caller's Mutex, after casting */
+ DWORD wtime; /* Windows time value */
+ int timeout; /* True if we got a timeout */
+ int doExit = 0; /* True if we need to do exit setup */
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ if (tsdPtr->flags & WIN_THREAD_DEAD) {
+ /*
+ * No more per-thread event on which to wait.
+ */
+
+ return;
+ }
+
+ /*
+ * Self initialize the two parts of the contition.
+ * The per-condition and per-thread parts need to be
+ * handled independently.
+ */
+
+ if (tsdPtr->flags == WIN_THREAD_UNINIT) {
+ MASTER_LOCK;
+
+ /*
+ * Create the per-thread event and queue pointers.
+ */
+
+ if (tsdPtr->flags == WIN_THREAD_UNINIT) {
+ tsdPtr->condEvent = CreateEvent(NULL, TRUE /* manual reset */,
+ FALSE /* non signaled */, NULL);
+ tsdPtr->nextPtr = NULL;
+ tsdPtr->prevPtr = NULL;
+ tsdPtr->flags = WIN_THREAD_RUNNING;
+ doExit = 1;
+ }
+ MASTER_UNLOCK;
+
+ if (doExit) {
+ /*
+ * Create a per-thread exit handler to clean up the condEvent.
+ * We must be careful do do this outside the Master Lock
+ * because Tcl_CreateThreadExitHandler uses its own
+ * ThreadSpecificData, and initializing that may drop
+ * back into the Master Lock.
+ */
+
+ Tcl_CreateThreadExitHandler(FinalizeConditionEvent,
+ (ClientData) tsdPtr);
+ }
+ }
+
+ if (*condPtr == NULL) {
+ MASTER_LOCK;
+
+ /*
+ * Initialize the per-condition queue pointers and Mutex.
+ */
+
+ if (*condPtr == NULL) {
+ winCondPtr = (WinCondition *)ckalloc(sizeof(WinCondition));
+ InitializeCriticalSection(&winCondPtr->condLock);
+ winCondPtr->firstPtr = NULL;
+ winCondPtr->lastPtr = NULL;
+ *condPtr = (Tcl_Condition)winCondPtr;
+ TclRememberCondition(condPtr);
+ }
+ MASTER_UNLOCK;
+ }
+ csPtr = *((CRITICAL_SECTION **)mutexPtr);
+ winCondPtr = *((WinCondition **)condPtr);
+ if (timePtr == NULL) {
+ wtime = INFINITE;
+ } else {
+ wtime = timePtr->sec * 1000 + timePtr->usec / 1000;
+ }
+
+ /*
+ * Queue the thread on the condition, using
+ * the per-condition lock for serialization.
+ */
+
+ tsdPtr->flags = WIN_THREAD_BLOCKED;
+ tsdPtr->nextPtr = NULL;
+ EnterCriticalSection(&winCondPtr->condLock);
+ tsdPtr->prevPtr = winCondPtr->lastPtr; /* A: */
+ winCondPtr->lastPtr = tsdPtr;
+ if (tsdPtr->prevPtr != NULL) {
+ tsdPtr->prevPtr->nextPtr = tsdPtr;
+ }
+ if (winCondPtr->firstPtr == NULL) {
+ winCondPtr->firstPtr = tsdPtr;
+ }
+
+ /*
+ * Unlock the caller's mutex and wait for the condition, or a timeout.
+ * There is a minor issue here in that we don't count down the
+ * timeout if we get notified, but another thread grabs the condition
+ * before we do. In that race condition we'll wait again for the
+ * full timeout. Timed waits are dubious anyway. Either you have
+ * the locking protocol wrong and are masking a deadlock,
+ * or you are using conditions to pause your thread.
+ */
+
+ LeaveCriticalSection(csPtr);
+ timeout = 0;
+ while (!timeout && (tsdPtr->flags & WIN_THREAD_BLOCKED)) {
+ ResetEvent(tsdPtr->condEvent);
+ LeaveCriticalSection(&winCondPtr->condLock);
+ if (WaitForSingleObject(tsdPtr->condEvent, wtime) == WAIT_TIMEOUT) {
+ timeout = 1;
+ }
+ EnterCriticalSection(&winCondPtr->condLock);
+ }
+
+ /*
+ * Be careful on timeouts because the signal might arrive right around
+ * time time limit and someone else could have taken us off the queue.
+ */
+
+ if (timeout) {
+ if (tsdPtr->flags & WIN_THREAD_RUNNING) {
+ timeout = 0;
+ } else {
+ /*
+ * When dequeuing, we can leave the tsdPtr->nextPtr
+ * and tsdPtr->prevPtr with dangling pointers because
+ * they are reinitialilzed w/out reading them when the
+ * thread is enqueued later.
+ */
+
+ if (winCondPtr->firstPtr == tsdPtr) {
+ winCondPtr->firstPtr = tsdPtr->nextPtr;
+ } else {
+ tsdPtr->prevPtr->nextPtr = tsdPtr->nextPtr;
+ }
+ if (winCondPtr->lastPtr == tsdPtr) {
+ winCondPtr->lastPtr = tsdPtr->prevPtr;
+ } else {
+ tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
+ }
+ tsdPtr->flags = WIN_THREAD_RUNNING;
+ }
+ }
+
+ LeaveCriticalSection(&winCondPtr->condLock);
+ EnterCriticalSection(csPtr);
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ConditionNotify --
+ *
+ * This procedure is invoked to signal a condition variable.
+ *
+ * The mutex must be held during this call to avoid races,
+ * but this interface does not enforce that.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * May unblock another thread.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_ConditionNotify(condPtr)
+ Tcl_Condition *condPtr;
+{
+ WinCondition *winCondPtr;
+ ThreadSpecificData *tsdPtr;
+ if (condPtr != NULL) {
+ winCondPtr = *((WinCondition **)condPtr);
+
+ /*
+ * Loop through all the threads waiting on the condition
+ * and notify them (i.e., broadcast semantics). The queue
+ * manipulation is guarded by the per-condition coordinating mutex.
+ */
+
+ EnterCriticalSection(&winCondPtr->condLock);
+ while (winCondPtr->firstPtr != NULL) {
+ tsdPtr = winCondPtr->firstPtr;
+ winCondPtr->firstPtr = tsdPtr->nextPtr;
+ if (winCondPtr->lastPtr == tsdPtr) {
+ winCondPtr->lastPtr = NULL;
+ }
+ tsdPtr->flags = WIN_THREAD_RUNNING;
+ tsdPtr->nextPtr = NULL;
+ tsdPtr->prevPtr = NULL; /* Not strictly necessary, see A: */
+ SetEvent(tsdPtr->condEvent);
+ }
+ LeaveCriticalSection(&winCondPtr->condLock);
+ } else {
+ /*
+ * Noone has used the condition variable, so there are no waiters.
+ */
+ }
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FinalizeConditionEvent --
+ *
+ * This procedure is invoked to clean up the per-thread
+ * event used to implement condition waiting.
+ * This is only safe to call at the end of time.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The per-thread event is closed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FinalizeConditionEvent(data)
+ ClientData data;
+{
+ ThreadSpecificData *tsdPtr = (ThreadSpecificData *)data;
+ tsdPtr->flags = WIN_THREAD_DEAD;
+ CloseHandle(tsdPtr->condEvent);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpFinalizeCondition --
+ *
+ * This procedure is invoked to clean up a condition variable.
+ * This is only safe to call at the end of time.
+ *
+ * This assumes the Master Lock is held.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The condition variable is deallocated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpFinalizeCondition(condPtr)
+ Tcl_Condition *condPtr;
+{
+ WinCondition *winCondPtr = *(WinCondition **)condPtr;
+
+ /*
+ * Note - this is called long after the thread-local storage is
+ * reclaimed. The per-thread condition waiting event is
+ * reclaimed earlier in a per-thread exit handler, which is
+ * called before thread local storage is reclaimed.
+ */
+
+ if (winCondPtr != NULL) {
+ ckfree((char *)winCondPtr);
+ *condPtr = NULL;
+ }
+}
+#endif /* TCL_THREADS */
diff --git a/win/tclWinThrd.h b/win/tclWinThrd.h
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 0630caf..de0e3dd 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.
*
- * RCS: @(#) $Id: tclWinTime.c,v 1.3 1999/03/10 05:52:54 stanton Exp $
+ * RCS: @(#) $Id: tclWinTime.c,v 1.4 1999/04/16 00:48:10 stanton Exp $
*/
-#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;
}
/*
@@ -196,7 +257,6 @@ TclpGetDate(t, useGMT)
int useGMT;
{
const time_t *tp = (const time_t *) t;
-
struct tm *tmPtr;
long time;
@@ -209,10 +269,11 @@ TclpGetDate(t, useGMT)
* algorithm ignores daylight savings time before the epoch.
*/
- time = *tp - _timezone;
- if (time >= 0) {
+ if (*tp >= 0) {
return localtime(tp);
}
+
+ time = *tp - _timezone;
/*
* If we aren't near to overflowing the long, just add the bias and
@@ -274,7 +335,7 @@ TclpGetDate(t, 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.
@@ -286,10 +347,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.
@@ -329,47 +393,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 098ec86..44a3f35 100644
--- a/win/tclsh.rc
+++ b/win/tclsh.rc
@@ -1,4 +1,4 @@
-// RCS: @(#) $Id: tclsh.rc,v 1.2 1998/09/14 18:40:20 stanton Exp $
+// RCS: @(#) $Id: tclsh.rc,v 1.3 1999/04/16 00:48:10 stanton Exp $
//
// 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